Released DG*5.3*1040 SEQ #912 Extracted from mail message **KIDS**:DG*5.3*1040^ **INSTALL NAME** DG*5.3*1040 "BLD",11986,0) DG*5.3*1040^REGISTRATION^0^3210315^y "BLD",11986,1,0) ^^2^2^3210106^ "BLD",11986,1,1,0) Please refer to the National Patch Module for the detail of this "BLD",11986,1,2,0) patch build. "BLD",11986,4,0) ^9.64PA^^ "BLD",11986,6) 2^ "BLD",11986,6.3) 15 "BLD",11986,"ABPKG") n "BLD",11986,"KRN",0) ^9.67PA^1.5^25 "BLD",11986,"KRN",.4,0) .4 "BLD",11986,"KRN",.401,0) .401 "BLD",11986,"KRN",.402,0) .402 "BLD",11986,"KRN",.403,0) .403 "BLD",11986,"KRN",.5,0) .5 "BLD",11986,"KRN",.84,0) .84 "BLD",11986,"KRN",1.5,0) 1.5 "BLD",11986,"KRN",1.6,0) 1.6 "BLD",11986,"KRN",1.61,0) 1.61 "BLD",11986,"KRN",1.62,0) 1.62 "BLD",11986,"KRN",3.6,0) 3.6 "BLD",11986,"KRN",3.8,0) 3.8 "BLD",11986,"KRN",9.2,0) 9.2 "BLD",11986,"KRN",9.8,0) 9.8 "BLD",11986,"KRN",9.8,"NM",0) ^9.68A^16^16 "BLD",11986,"KRN",9.8,"NM",1,0) DG10^^0^B32850951 "BLD",11986,"KRN",9.8,"NM",2,0) DGREG^^0^B160323026 "BLD",11986,"KRN",9.8,"NM",3,0) DGRP^^0^B2606972 "BLD",11986,"KRN",9.8,"NM",4,0) DGRPE^^0^B108399788 "BLD",11986,"KRN",9.8,"NM",5,0) DGRPP^^0^B22781007 "BLD",11986,"KRN",9.8,"NM",6,0) DGREGRED^^0^B89579662 "BLD",11986,"KRN",9.8,"NM",7,0) DGREGAED^^0^B71144811 "BLD",11986,"KRN",9.8,"NM",8,0) DGREGTED^^0^B71965031 "BLD",11986,"KRN",9.8,"NM",9,0) DGREGCP1^^0^B34041962 "BLD",11986,"KRN",9.8,"NM",10,0) DGADDUTL^^0^B72545598 "BLD",11986,"KRN",9.8,"NM",11,0) DGREGTE2^^0^B21247832 "BLD",11986,"KRN",9.8,"NM",12,0) DGENDBS^^0^B5434355 "BLD",11986,"KRN",9.8,"NM",13,0) DGADDLST^^0^B25393125 "BLD",11986,"KRN",9.8,"NM",14,0) DGADDVAL^^0^B11543186 "BLD",11986,"KRN",9.8,"NM",15,0) DGLOCK^^0^B53950031 "BLD",11986,"KRN",9.8,"NM",16,0) DGLOCK3^^0^B11146338 "BLD",11986,"KRN",9.8,"NM","B","DG10",1) "BLD",11986,"KRN",9.8,"NM","B","DGADDLST",13) "BLD",11986,"KRN",9.8,"NM","B","DGADDUTL",10) "BLD",11986,"KRN",9.8,"NM","B","DGADDVAL",14) "BLD",11986,"KRN",9.8,"NM","B","DGENDBS",12) "BLD",11986,"KRN",9.8,"NM","B","DGLOCK",15) "BLD",11986,"KRN",9.8,"NM","B","DGLOCK3",16) "BLD",11986,"KRN",9.8,"NM","B","DGREG",2) "BLD",11986,"KRN",9.8,"NM","B","DGREGAED",7) "BLD",11986,"KRN",9.8,"NM","B","DGREGCP1",9) "BLD",11986,"KRN",9.8,"NM","B","DGREGRED",6) "BLD",11986,"KRN",9.8,"NM","B","DGREGTE2",11) "BLD",11986,"KRN",9.8,"NM","B","DGREGTED",8) "BLD",11986,"KRN",9.8,"NM","B","DGRP",3) "BLD",11986,"KRN",9.8,"NM","B","DGRPE",4) "BLD",11986,"KRN",9.8,"NM","B","DGRPP",5) "BLD",11986,"KRN",19,0) 19 "BLD",11986,"KRN",19.1,0) 19.1 "BLD",11986,"KRN",101,0) 101 "BLD",11986,"KRN",409.61,0) 409.61 "BLD",11986,"KRN",771,0) 771 "BLD",11986,"KRN",771,"NM",0) ^9.68A^^ "BLD",11986,"KRN",779.2,0) 779.2 "BLD",11986,"KRN",870,0) 870 "BLD",11986,"KRN",8989.51,0) 8989.51 "BLD",11986,"KRN",8989.51,"NM",0) ^9.68A^^ "BLD",11986,"KRN",8989.52,0) 8989.52 "BLD",11986,"KRN",8993,0) 8993 "BLD",11986,"KRN",8994,0) 8994 "BLD",11986,"KRN","B",.4,.4) "BLD",11986,"KRN","B",.401,.401) "BLD",11986,"KRN","B",.402,.402) "BLD",11986,"KRN","B",.403,.403) "BLD",11986,"KRN","B",.5,.5) "BLD",11986,"KRN","B",.84,.84) "BLD",11986,"KRN","B",1.5,1.5) "BLD",11986,"KRN","B",1.6,1.6) "BLD",11986,"KRN","B",1.61,1.61) "BLD",11986,"KRN","B",1.62,1.62) "BLD",11986,"KRN","B",3.6,3.6) "BLD",11986,"KRN","B",3.8,3.8) "BLD",11986,"KRN","B",9.2,9.2) "BLD",11986,"KRN","B",9.8,9.8) "BLD",11986,"KRN","B",19,19) "BLD",11986,"KRN","B",19.1,19.1) "BLD",11986,"KRN","B",101,101) "BLD",11986,"KRN","B",409.61,409.61) "BLD",11986,"KRN","B",771,771) "BLD",11986,"KRN","B",779.2,779.2) "BLD",11986,"KRN","B",870,870) "BLD",11986,"KRN","B",8989.51,8989.51) "BLD",11986,"KRN","B",8989.52,8989.52) "BLD",11986,"KRN","B",8993,8993) "BLD",11986,"KRN","B",8994,8994) "BLD",11986,"QDEF") ^^^^NO^^^^NO^^YES "BLD",11986,"QUES",0) ^9.62^^ "BLD",11986,"REQB",0) ^9.611^2^2 "BLD",11986,"REQB",1,0) DG*5.3*1014^1 "BLD",11986,"REQB",2,0) DG*5.3*993^1 "BLD",11986,"REQB","B","DG*5.3*1014",1) "BLD",11986,"REQB","B","DG*5.3*993",2) "MBREQ") 0 "PKG",5,-1) 1^1 "PKG",5,0) REGISTRATION^DG^PATIENT REGISTRATION, ADMISSION, DISCHARGE, EMBOSSER "PKG",5,22,0) ^9.49I^1^1 "PKG",5,22,1,0) 5.3^2930813 "PKG",5,22,1,"PAH",1,0) 1040^3210315^1580 "PKG",5,22,1,"PAH",1,1,0) ^^2^2^3210315 "PKG",5,22,1,"PAH",1,1,1,0) Please refer to the National Patch Module for the detail of this "PKG",5,22,1,"PAH",1,1,2,0) patch build. "QUES","XPF1",0) Y "QUES","XPF1","??") ^D REP^XPDH "QUES","XPF1","A") Shall I write over your |FLAG| File "QUES","XPF1","B") YES "QUES","XPF1","M") D XPF1^XPDIQ "QUES","XPF2",0) Y "QUES","XPF2","??") ^D DTA^XPDH "QUES","XPF2","A") Want my data |FLAG| yours "QUES","XPF2","B") YES "QUES","XPF2","M") D XPF2^XPDIQ "QUES","XPI1",0) YO "QUES","XPI1","??") ^D INHIBIT^XPDH "QUES","XPI1","A") Want KIDS to INHIBIT LOGONs during the install "QUES","XPI1","B") NO "QUES","XPI1","M") D XPI1^XPDIQ "QUES","XPM1",0) PO^VA(200,:EM "QUES","XPM1","??") ^D MG^XPDH "QUES","XPM1","A") Enter the Coordinator for Mail Group '|FLAG|' "QUES","XPM1","B") "QUES","XPM1","M") D XPM1^XPDIQ "QUES","XPO1",0) Y "QUES","XPO1","??") ^D MENU^XPDH "QUES","XPO1","A") Want KIDS to Rebuild Menu Trees Upon Completion of Install "QUES","XPO1","B") NO "QUES","XPO1","M") D XPO1^XPDIQ "QUES","XPZ1",0) Y "QUES","XPZ1","??") ^D OPT^XPDH "QUES","XPZ1","A") Want to DISABLE Scheduled Options, Menu Options, and Protocols "QUES","XPZ1","B") YES "QUES","XPZ1","M") D XPZ1^XPDIQ "QUES","XPZ2",0) Y "QUES","XPZ2","??") ^D RTN^XPDH "QUES","XPZ2","A") Want to MOVE routines to other CPUs "QUES","XPZ2","B") NO "QUES","XPZ2","M") D XPZ2^XPDIQ "RTN") 16 "RTN","DG10") 0^1^B32850951^B30243859 "RTN","DG10",1,0) DG10 ;ALB/MRL,DAK,AEG,PHH,TMK,ASMR/JD-LOAD/EDIT PATIENT DATA ; 09/30/15 @ 08:34 "RTN","DG10",2,0) ;;5.3;Registration;**32,109,139,149,182,326,513,425,574,642,658,773,864,921,993,1040**;Aug 13, 1993;Build 15 "RTN","DG10",3,0) ;Per VHA Directive 2004-038, this routine should not be modified. "RTN","DG10",4,0) ; "RTN","DG10",5,0) ;Done for eHMP project: DG*5.3*921 "RTN","DG10",6,0) ;Added logic to trigger unsolicited updates for demographics that are not otherwise triggered "RTN","DG10",7,0) ;by the TRIGGER x-ref. New code: Tags T, T59, and T60 and any references to those tags thereof. "RTN","DG10",8,0) START ; "RTN","DG10",9,0) D LO^DGUTL "RTN","DG10",10,0) I $G(DGPRFLG)=1,$G(DGPLOC)=1 D G Q:$G(DGRPOUT),A1 "RTN","DG10",11,0) .; D EN^DGRPD,REG^IVMCQ($G(DFN)) "RTN","DG10",12,0) . D EN^DGRPD "RTN","DG10",13,0) . Q:$G(DGRPOUT) "RTN","DG10",14,0) . D REG^IVMCQ($G(DFN)) "RTN","DG10",15,0) . D HINQ "RTN","DG10",16,0) ; "RTN","DG10",17,0) ; DG*5.3*993; Remove the DLAYGO variable and the "L" from DIC(0) since adding records to the PATIENT file is not allowed in DG LOAD PATIENT DATA "RTN","DG10",18,0) A ;W !! K VET,DIE,DIC,CARD S DIC=2,DLAYGO=2,DIC(0)="ALEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO "RTN","DG10",19,0) ; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL "RTN","DG10",20,0) N DGADDRE,DGTMOT S DGTMOT=0,DGADDRE="" "RTN","DG10",21,0) W !! K VET,DIE,DIC,CARD S DIC=2,DIC(0)="AEQM" K DIC("S") D ^DIC G Q:Y<0 S (DFN,DA)=+Y,DGNEW=$P(Y,"^",3) K DLAYGO "RTN","DG10",22,0) ;DG*5.3*921 Invoke eHMP demographic change checking "RTN","DG10",23,0) I DGNEW']"" D T59(DFN,"BEFORE") ;Get a snapshot of the demographics before changes "RTN","DG10",24,0) N Y D PAUSE I DGNEW D NEW^DGRP S DA=DFN,VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0) "RTN","DG10",25,0) ; "RTN","DG10",26,0) ;MPI QUERY "RTN","DG10",27,0) ;check to see if CIRN PD/MPI is installed "RTN","DG10",28,0) N X S X="MPIFAPI" X ^%ZOSF("TEST") G:'$T SKIP "RTN","DG10",29,0) K MPIFRTN "RTN","DG10",30,0) D MPIQ^MPIFAPI(DFN) "RTN","DG10",31,0) K MPIFRTN "RTN","DG10",32,0) ; "RTN","DG10",33,0) N DGNOIVMUPD "RTN","DG10",34,0) S DGNOIVMUPD=1 ; Set flag to prevent MT Event Driver from updating converted IVM test "RTN","DG10",35,0) I +$G(DGNEW) D "RTN","DG10",36,0) . ; query CMOR for Patient Record Flag Assignments if NEW patient and "RTN","DG10",37,0) . ; display results "RTN","DG10",38,0) . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) "RTN","DG10",39,0) . I $$EN^DGPFMPI(DFN) "RTN","DG10",40,0) ; "RTN","DG10",41,0) SKIP ; "RTN","DG10",42,0) ;DG*5.3*921 Invoke eHMP demographic change checking (via D T) "RTN","DG10",43,0) S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) K DGRPOUT D T G A "RTN","DG10",44,0) D HINQ,REG^IVMCQ($G(DFN)) G A1 "RTN","DG10",45,0) ; "RTN","DG10",46,0) HINQ ; "RTN","DG10",47,0) S Y=$S($D(^DG(43,1,0)):^(0),1:0) I $P(Y,U,27) S X="DVBHQZ4" X ^%ZOSF("TEST") I $T D "RTN","DG10",48,0) .N DGROUT "RTN","DG10",49,0) .S DGROUT=X "RTN","DG10",50,0) .I $G(DFN) D "RTN","DG10",51,0) ..N X,Y,DGRP "RTN","DG10",52,0) ..F X=.3,.32 S DGRP(X)=$G(^DPT(DFN,X)) "RTN","DG10",53,0) ..W !," Money Verified: " S Y=$P(DGRP(.3),"^",6) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED") "RTN","DG10",54,0) ..W ?40," Service Verified: " S Y=$P(DGRP(.32),"^",2) X:Y]"" ^DD("DD") W $S(Y]"":Y,1:"NOT VERIFIED") "RTN","DG10",55,0) .D @("EN^"_DGROUT) K Y Q ;from dgdem0 "RTN","DG10",56,0) Q "RTN","DG10",57,0) ; "RTN","DG10",58,0) ; SDIEMM is used as a flag by AMBCARE Incomplete Encounter Management "RTN","DG10",59,0) ; to bypass the embossing routines when calling load/edit from IEMM "RTN","DG10",60,0) ; "RTN","DG10",61,0) ; DG*5.3*1040 - If variable DGADDRE=-1, branch to RPOUT due to timeout; if DGRPOUT=1, branch to RPOUT as well "RTN","DG10",62,0) A1 D G:$G(DGADDRE)=-1 RPOUT G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G:+$G(DGRPOUT) RPOUT D MT(DFN),CP G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) G Q:'$D(DA),EMBOS "RTN","DG10",63,0) .W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" "RTN","DG10",64,0) .S %=1 D YN^DICN "RTN","DG10",65,0) .I +$G(DGNEW) Q "RTN","DG10",66,0) .S DGADDRE=$$ADD^DGADDUTL($G(DFN)) ; DG*5.3*1040 - Store the return value in DGADDRE "RTN","DG10",67,0) ; "RTN","DG10",68,0) H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue without",!?5,"editing." "RTN","DG10",69,0) G A1 "RTN","DG10",70,0) ; "RTN","DG10",71,0) ; DG*5.3*1040 - Only do if there wasn't a timeout so branch to RPOUT "RTN","DG10",72,0) CK S DGEDCN=1 G:+$G(DGRPOUT) RPOUT D ^DGRPC,MT(DFN),CP "RTN","DG10",73,0) G Q:$G(DGPRFLG)=1 G Q:$G(SDIEMM) "RTN","DG10",74,0) I $G(DGER)[55 K DIR S DIR(0)="Y",DIR("A")="Do you wish to return to Screen #9 to enter missing Income Data? " D ^DIR K DIR "RTN","DG10",75,0) ;G:Y ^DGRP9 "RTN","DG10",76,0) ; "RTN","DG10",77,0) EMBOS ;W ! D EMBOS^DGQEMA G A "RTN","DG10",78,0) ;DG*5.3*921 Invoke eHMP demographic change checking "RTN","DG10",79,0) D T "RTN","DG10",80,0) G A "RTN","DG10",81,0) ; "RTN","DG10",82,0) ; "RTN","DG10",83,0) ; DG*5.3*1040 - Clean variable DGTMOT "RTN","DG10",84,0) Q K X,Y,Z,DIC,DGELVER,DGNEW,DGRPV,DGTMOT,VET Q "RTN","DG10",85,0) ; "RTN","DG10",86,0) MT(DFN) ; Check if user requires a means test. Ask user if they want to proceedif "RTN","DG10",87,0) ; one is required "RTN","DG10",88,0) I '$D(SDIEMM) DO "RTN","DG10",89,0) .N DGREQF,DIV "RTN","DG10",90,0) .D EN^DGMTR "RTN","DG10",91,0) .I DGREQF D EDT^DGMTU(DFN,DT):$P($$MTS^DGMTU(DFN),U,2)="R" "RTN","DG10",92,0) .Q "RTN","DG10",93,0) I $D(SDIEMM) DO "RTN","DG10",94,0) .N DGMTI "RTN","DG10",95,0) .S DGMTI=$$LST^DGMTU(DFN,SCINF("ENCOUNTER"),1) "RTN","DG10",96,0) .I $P(DGMTI,U,4)="R" D I 1 "RTN","DG10",97,0) ..S DGMT0=$G(^DGMT(408.31,+DGMTI,0)),DGMTDT=$P(DGMT0,"^") "RTN","DG10",98,0) ..I '$$OKTOCONT(DGMTDT) Q "RTN","DG10",99,0) ..S DGMTI=+DGMTI,DGMTYPT=1,DGMTACT="COM",DGMTROU="COM^DGMTEO" D EN^DGMTSC "RTN","DG10",100,0) .E D WARNING "RTN","DG10",101,0) .Q "RTN","DG10",102,0) Q "RTN","DG10",103,0) ; "RTN","DG10",104,0) WARNING ; "RTN","DG10",105,0) ;prints a warning to the screen about means test "RTN","DG10",106,0) ; "RTN","DG10",107,0) W !!,"A means test for this encounter date was not found and may be required!" "RTN","DG10",108,0) W !,"Further investigation will be needed." "RTN","DG10",109,0) W ! "RTN","DG10",110,0) D PAUSE "RTN","DG10",111,0) Q "RTN","DG10",112,0) ; "RTN","DG10",113,0) PAUSE ; "RTN","DG10",114,0) N DIR "RTN","DG10",115,0) S DIR(0)="FAO",DIR("A")="Press ENTER to continue " D ^DIR "RTN","DG10",116,0) Q "RTN","DG10",117,0) ; "RTN","DG10",118,0) OKTOCONT(Y) ; "RTN","DG10",119,0) ; "RTN","DG10",120,0) N DIR "RTN","DG10",121,0) W !!,"Patient Requires a means Test" "RTN","DG10",122,0) X ^DD("DD") "RTN","DG10",123,0) W !,"Primary Means Test Required from '",Y,"'",! "RTN","DG10",124,0) ; "RTN","DG10",125,0) I $D(SDIEMM),'$D(^XUSEC("SCENI MEANS TEST EDIT",DUZ)) DO G OKQ "RTN","DG10",126,0) .W !,$C(7),"You do not have the appropriate IEMM Security Key. Contact your supervisor.",! "RTN","DG10",127,0) .D PAUSE "RTN","DG10",128,0) .S Y=0 "RTN","DG10",129,0) ; "RTN","DG10",130,0) S DIR("A")="Do you wish to proceed with the means test at this time" "RTN","DG10",131,0) S DIR("B")="YES" "RTN","DG10",132,0) S DIR(0)="Y" "RTN","DG10",133,0) D ^DIR "RTN","DG10",134,0) OKQ Q $S(Y=1:1,1:0) "RTN","DG10",135,0) ; "RTN","DG10",136,0) CP ;If not (autoexempt or MTested) & no CP test this year then "RTN","DG10",137,0) ;prompt for add/edit cp test "RTN","DG10",138,0) N DIV,DGIB,DGIBDT,DGX,X,DIRUT,DTOUT "RTN","DG10",139,0) G:'$P($G(^DG(43,1,0)),U,41) QTCP ;USE CP FLAG "RTN","DG10",140,0) S DGIBDT=$S($D(DFN1):9999999-DFN1,1:DT) "RTN","DG10",141,0) D EN^DGMTCOR "RTN","DG10",142,0) I +$G(DGNOCOPF) S DGMTCOR=0 "RTN","DG10",143,0) I DGMTCOR D THRESH^DGMTCOU1(DGIBDT) D EDT^DGMTCOU(DFN,DT) "RTN","DG10",144,0) K DGNOCOPF "RTN","DG10",145,0) QTCP Q "RTN","DG10",146,0) ; "RTN","DG10",147,0) T ; "RTN","DG10",148,0) ;DG*5.3*921- Check to ensure all demographic changes are passed to eHMP 10/2/15 "RTN","DG10",149,0) ;If we are editing demographics for an existing patient, get a snapshot after "RTN","DG10",150,0) ;the changes and compare the before and after snapshots. If there are ANY changes "RTN","DG10",151,0) ;invoke the unsolicited update protocol. "RTN","DG10",152,0) I DGNEW']"" D "RTN","DG10",153,0) .N DGFIELD,DGFILE,DGDA "RTN","DG10",154,0) .D T59(DFN,"AFTER") "RTN","DG10",155,0) .I $$T60("BEFORE","AFTER",.DGFIELD) S DGFILE=2,DGDA=DFN D:$L($T(DG^HMPEVNT)) DG^HMPEVNT "RTN","DG10",156,0) Q "RTN","DG10",157,0) ; "RTN","DG10",158,0) T59(A,B) ;Get all the demographics that are supposed to trigger an unsolicited update "RTN","DG10",159,0) ;DG*5.3*921 "RTN","DG10",160,0) ;A = DFN "RTN","DG10",161,0) ;B = Return array "RTN","DG10",162,0) N FLDS,INS "RTN","DG10",163,0) S FLDS=".01;.02;.03;.05;.08;.09;.351;.361;.364;.111;.1112;.112;.113;.114;.115;.131;.132;.134;" "RTN","DG10",164,0) S FLDS=FLDS_".211;.212;.213;.214;.216;.217;.218;.219;.301;.302;1901;.32102;.32103;.32201;.5295;" "RTN","DG10",165,0) S FLDS=FLDS_".133;.1211;.1212;.1213;.1214;.1215;.1216;.331;.332;.333;.334;.335;.336;.337;" "RTN","DG10",166,0) S FLDS=FLDS_".338;.339;.33011;.215;.21011;.3731;" "RTN","DG10",167,0) D GETS^DIQ(2,A_",",FLDS,,B) "RTN","DG10",168,0) Q "RTN","DG10",169,0) ; "RTN","DG10",170,0) T60(A,B,C) ;Compare the before and after arrays to see if any of the considerd demographics "RTN","DG10",171,0) ;were changed "RTN","DG10",172,0) ;DG*5.3*921 "RTN","DG10",173,0) ;A = "before" changes array "RTN","DG10",174,0) ;B = "after" changes array "RTN","DG10",175,0) ;Both A and B are of the form: A(2,DFN_",",Field#)=Field value. E.g. A(2,"3,",.114)="LOS ANGELES" "RTN","DG10",176,0) ;C = the first field that was changed (e.g. .111 for street address line 1). "RTN","DG10",177,0) ; This is an output parameter. "RTN","DG10",178,0) ;Returns true (1) if any change is detected. Quits at the FIRST find. "RTN","DG10",179,0) ; false (null) if there are no changes. "RTN","DG10",180,0) N F,X,Y,Z "RTN","DG10",181,0) S (C,F,Z)="" "RTN","DG10",182,0) F S Z=$O(@A@(Z)) Q:$G(F)!(Z'=+Z) D "RTN","DG10",183,0) .S Y="" "RTN","DG10",184,0) .F S Y=$O(@A@(Z,Y)) Q:$G(F)!(Y']"") D "RTN","DG10",185,0) ..S X="" "RTN","DG10",186,0) ..F S X=$O(@A@(Z,Y,X)) Q:$G(F)!(X'=+X) D "RTN","DG10",187,0) ...I @A@(Z,Y,X)'=$G(@B@(Z,Y,X)) S F=1,C=X Q "RTN","DG10",188,0) Q F "RTN","DG10",189,0) ; DG*5.3*1040 - Entry point to quit and go to next select patient prompt "RTN","DG10",190,0) RPOUT ; Entry point if user timeout out "RTN","DG10",191,0) S DGRPOUT="" "RTN","DG10",192,0) G A "RTN","DGADDLST") 0^13^B25393125^B24537445 "RTN","DGADDLST",1,0) DGADDLST ;ALB/JAM - List Manager Screen for Address Validation ;Jun 12, 2020@12:34 "RTN","DGADDLST",2,0) ;;5.3;Registration;**1014,1040**;AUG 13, 1993;Build 15 "RTN","DGADDLST",3,0) ; "RTN","DGADDLST",4,0) EN(DFN,DGFLDS,DGADDR,DGSELADD,DGTMOT) ;Main entry point to invoke the "DGEN ADDR VALID" list - called by DGADDVAL "RTN","DGADDLST",5,0) ; Input: DFN - Patient IEN "RTN","DGADDLST",6,0) ; DGFLDS - String of address field numbers "RTN","DGADDLST",7,0) ; DGADDR (Pass by reference) - Array containing the addresses to list "RTN","DGADDLST",8,0) ; Output: DGSELADD (Pass by reference) - Array containing selected address "RTN","DGADDLST",9,0) ; DGTMOT (Pass by reference) - DG*5.3*1040 - If "1", a timeout occurred "RTN","DGADDLST",10,0) ; "RTN","DGADDLST",11,0) ; DGFLDS - Field numbers are in the following format: "RTN","DGADDLST",12,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGADDLST",13,0) ; "RTN","DGADDLST",14,0) ; DGADDR Format: "RTN","DGADDLST",15,0) ; DGADDR = Total number of records "RTN","DGADDLST",16,0) ; DGADDR(Counter,field#)=VALUE ForState: VALUE = "STATENAME^STATECODE" "RTN","DGADDLST",17,0) ; For Country: VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDLST",18,0) ; "RTN","DGADDLST",19,0) ; DGSELADD Format: "RTN","DGADDLST",20,0) ; DGSELADD(field#)=VALUE ForState: VALUE = "STATENAME^STATECODE" "RTN","DGADDLST",21,0) ; For Country: VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDLST",22,0) ; "RTN","DGADDLST",23,0) D WAIT^DICD "RTN","DGADDLST",24,0) D EN^VALM("DGEN ADDR VALID") "RTN","DGADDLST",25,0) N VALMHDR,VALMBCK,VALMCNT,VALMSG,XQORM "RTN","DGADDLST",26,0) Q "RTN","DGADDLST",27,0) ; "RTN","DGADDLST",28,0) HDR ;Header code "RTN","DGADDLST",29,0) N X,DGSSNSTR,DGPTYPE,DGSSN,DGDOB "RTN","DGADDLST",30,0) S DGSSNSTR=$$SSNNM^DGRPU(DFN) ; add member id (edipi) and preferred name to banner "RTN","DGADDLST",31,0) S DGSSN=$P($P(DGSSNSTR,";",2)," ",3) "RTN","DGADDLST",32,0) S DGDOB=$$GET1^DIQ(2,DFN,.03,"I") "RTN","DGADDLST",33,0) S DGDOB=$$UP^XLFSTR($$FMTE^XLFDT($E(DGDOB,1,12),1)) "RTN","DGADDLST",34,0) S DGPTYPE=$$GET1^DIQ(391,$$GET1^DIQ(2,DFN_",",391,"I")_",",.01) "RTN","DGADDLST",35,0) S:DGPTYPE="" DGPTYPE="PATIENT TYPE UNKNOWN" "RTN","DGADDLST",36,0) ; If coming from screen 1.1, change the screen title to specify this as screen 1.2 "RTN","DGADDLST",37,0) ; - DGPRS is a system-wide variable containing the screen number "RTN","DGADDLST",38,0) ; - VALM array is used by ListMan (do not NEW this variable) "RTN","DGADDLST",39,0) ; It contains data for the screen and is used to maintain the call stack when a Listman screen flows to another ListMan screen. "RTN","DGADDLST",40,0) ; Changes to VALM entries are unwound after exit - Listman restores the entries of the previous stack level. "RTN","DGADDLST",41,0) I $G(DGRPS)=1.1 S VALM("TITLE")="Address Validation <1.2>" "RTN","DGADDLST",42,0) S VALMHDR(1)=$P(DGSSNSTR,";",1)_$S($$GET1^DIQ(2,DFN,.2405)'="":" ("_$$GET1^DIQ(2,DFN,.2405)_")",1:"")_" "_DGDOB "RTN","DGADDLST",43,0) S VALMHDR(2)=$S($P($P(DGSSNSTR,";",2)," ",2)'="":$E($P($P(DGSSNSTR,";",2)," ",2),1,40)_" ",1:"")_DGSSN_" "_DGPTYPE "RTN","DGADDLST",44,0) S XQORM("B")="SEL" "RTN","DGADDLST",45,0) Q "RTN","DGADDLST",46,0) ; "RTN","DGADDLST",47,0) INIT ;Build address screen "RTN","DGADDLST",48,0) D CLEAN^VALM10 "RTN","DGADDLST",49,0) K ^TMP("DGADDVAL",$J) "RTN","DGADDLST",50,0) N DGGLBL,DGCNT,DGZ,DGCTRYCD,DGFORGN,DGZIP "RTN","DGADDLST",51,0) S DGGLBL=$NA(^TMP("DGADDVAL",$J)) "RTN","DGADDLST",52,0) S VALMCNT=0,DGCNT=0 "RTN","DGADDLST",53,0) F S DGCNT=$O(DGADDR(DGCNT)) Q:'DGCNT D "RTN","DGADDLST",54,0) . ; Get Country code and determine if this is domestic/foreign address "RTN","DGADDLST",55,0) . S DGCTRYCD=$P(DGADDR(DGCNT,$P(DGFLDS,",",10)),"^",2) "RTN","DGADDLST",56,0) . S DGFORGN=0 "RTN","DGADDLST",57,0) . S DGFORGN=$$FORIEN^DGADDUTL(DGCTRYCD) "RTN","DGADDLST",58,0) . ; Save to List Manager array for display "RTN","DGADDLST",59,0) . ; Address line 1 "RTN","DGADDLST",60,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",61,0) . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",1)) "RTN","DGADDLST",62,0) . S DGZ="["_DGCNT_"] "_DGZ "RTN","DGADDLST",63,0) . S @DGGLBL@(VALMCNT,0)=DGZ "RTN","DGADDLST",64,0) . ; Address line 2 "RTN","DGADDLST",65,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",2)))'="" D "RTN","DGADDLST",66,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",67,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",2)) "RTN","DGADDLST",68,0) . . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",69,0) . ; Address line 3 "RTN","DGADDLST",70,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",3)))'="" D "RTN","DGADDLST",71,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",72,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",3)) "RTN","DGADDLST",73,0) . . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",74,0) . ; Put together line for city, state zip or city Province Postal Code "RTN","DGADDLST",75,0) . S DGZ="" "RTN","DGADDLST",76,0) . ; City "RTN","DGADDLST",77,0) . I $G(DGADDR(DGCNT,$P(DGFLDS,",",4)))'="" D "RTN","DGADDLST",78,0) . . S DGZ=DGADDR(DGCNT,$P(DGFLDS,",",4)) "RTN","DGADDLST",79,0) . ; For domestic address, add State and Zip "RTN","DGADDLST",80,0) . I 'DGFORGN D "RTN","DGADDLST",81,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",5)))'="" D "RTN","DGADDLST",82,0) . . . ; State "RTN","DGADDLST",83,0) . . . S DGZ=DGZ_","_$P(DGADDR(DGCNT,$P(DGFLDS,",",5)),"^",1) "RTN","DGADDLST",84,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",7)))'="" D "RTN","DGADDLST",85,0) . . . ; Zip "RTN","DGADDLST",86,0) . . . S DGZIP=DGADDR(DGCNT,$P(DGFLDS,",",7)) "RTN","DGADDLST",87,0) . . . S:$L(DGZIP)>5 DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,9) "RTN","DGADDLST",88,0) . . . S DGZ=DGZ_" "_DGZIP "RTN","DGADDLST",89,0) . ; For foreign address, add Province and Postal Code "RTN","DGADDLST",90,0) . I DGFORGN D "RTN","DGADDLST",91,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",8)))'="" D "RTN","DGADDLST",92,0) . . . ; Province "RTN","DGADDLST",93,0) . . . S DGZ=DGZ_" "_DGADDR(DGCNT,$P(DGFLDS,",",8)) "RTN","DGADDLST",94,0) . . I $G(DGADDR(DGCNT,$P(DGFLDS,",",9)))'="" D "RTN","DGADDLST",95,0) . . . ; Postal Code "RTN","DGADDLST",96,0) . . . S DGZ=DGZ_" "_DGADDR(DGCNT,$P(DGFLDS,",",9)) "RTN","DGADDLST",97,0) . ; Add the City string to list "RTN","DGADDLST",98,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",99,0) . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",100,0) . ; Country "RTN","DGADDLST",101,0) . S DGZ=$$CNTRYI^DGADDUTL(DGCTRYCD) "RTN","DGADDLST",102,0) . S DGZ=$S(DGZ="":"UNSPECIFIED COUNTRY",DGZ=-1:"UNKNOWN COUNTRY",1:DGZ) "RTN","DGADDLST",103,0) . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",104,0) . S @DGGLBL@(VALMCNT,0)=" "_DGZ "RTN","DGADDLST",105,0) . ; "RTN","DGADDLST",106,0) . I DGCNT=1 S VALMCNT=VALMCNT+1,@DGGLBL@(VALMCNT,0)=" (User Entered Address)" "RTN","DGADDLST",107,0) . I DGCNT>1 D "RTN","DGADDLST",108,0) . . S DGZ=" " "RTN","DGADDLST",109,0) . . S VALMCNT=VALMCNT+1 "RTN","DGADDLST",110,0) . . I $G(DGADDR(DGCNT,"deliveryPoint"))'="" S DGZ=DGZ_"Delivery Point: "_DGADDR(DGCNT,"deliveryPoint")_" " "RTN","DGADDLST",111,0) . . S DGZ=DGZ_"Confidence Score: "_$G(DGADDR(DGCNT,"confidenceScore")) "RTN","DGADDLST",112,0) . . S @DGGLBL@(VALMCNT,0)=DGZ "RTN","DGADDLST",113,0) Q "RTN","DGADDLST",114,0) ; "RTN","DGADDLST",115,0) HELP ;Help code "RTN","DGADDLST",116,0) S X="?" D DISP^XQORM1 W !! "RTN","DGADDLST",117,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGADDLST",118,0) Q "RTN","DGADDLST",119,0) ; "RTN","DGADDLST",120,0) EXIT ;Exit code "RTN","DGADDLST",121,0) D CLEAN^VALM10 "RTN","DGADDLST",122,0) D CLEAR^VALM1 "RTN","DGADDLST",123,0) K ^TMP("DGADDVAL",$J) "RTN","DGADDLST",124,0) Q "RTN","DGADDLST",125,0) ; "RTN","DGADDLST",126,0) PEXIT ;DGEN ADD VALID 1.2 MENU protocol exit code "RTN","DGADDLST",127,0) ; DG*5.3*1040; If timeout on the menu, set flag and quit "RTN","DGADDLST",128,0) I $D(DTOUT) S DGTMOT=1 "RTN","DGADDLST",129,0) S VALMSG="+ Next Screen - Prev Screen ?? More Actions" "RTN","DGADDLST",130,0) S XQORM("B")="SEL" "RTN","DGADDLST",131,0) Q "RTN","DGADDLST",132,0) ; "RTN","DGADDLST",133,0) ACT(DGACT) ; Entry point for menu action selection "RTN","DGADDLST",134,0) ; = "SEL" - Select an Address - "RTN","DGADDLST",135,0) ; "RTN","DGADDLST",136,0) N DGSEL "RTN","DGADDLST",137,0) ; SEL - user selects one address from the list - merge it into the return array "RTN","DGADDLST",138,0) I DGACT="SEL" S DGSEL=$$SEL() "RTN","DGADDLST",139,0) ; DG*5.3*1040; If timeout, set flag and quit "RTN","DGADDLST",140,0) I DGSEL=-1 S DGTMOT=1 Q "RTN","DGADDLST",141,0) I DGSEL M DGSELADD=DGADDR(DGSEL) Q "RTN","DGADDLST",142,0) ; "RTN","DGADDLST",143,0) S VALMBCK="R" "RTN","DGADDLST",144,0) S XQORM("B")="SEL" "RTN","DGADDLST",145,0) Q "RTN","DGADDLST",146,0) ; "RTN","DGADDLST",147,0) SEL() ; function, prompt to select address "RTN","DGADDLST",148,0) N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y "RTN","DGADDLST",149,0) S DIR(0)="NA^1:"_DGADDR "RTN","DGADDLST",150,0) S DIR("A",1)="",DIR("A")="Select Address (1-"_DGADDR_"): " D ^DIR K DIR "RTN","DGADDLST",151,0) ; DG*5.3*1040; return -1 on a timeout "RTN","DGADDLST",152,0) I $D(DTOUT) Q -1 "RTN","DGADDLST",153,0) Q X "RTN","DGADDUTL") 0^10^B72545598^B65854548 "RTN","DGADDUTL",1,0) DGADDUTL ;ALB/PHH,EG,BAJ,ERC,CKN,TDM,LBD,JAM - PATIENT ADDRESS ; 19 Jul 2017 3:03 PM "RTN","DGADDUTL",2,0) ;;5.3;Registration;**658,695,730,688,808,851,872,915,925,941,1010,1040**;Aug 13, 1993;Build 15 "RTN","DGADDUTL",3,0) Q "RTN","DGADDUTL",4,0) ADDR ; validate/edit Patient address (entry for DG ADDRESS UPDATE option) "RTN","DGADDUTL",5,0) N %,QUIT,DIC,Y,DFN,USERSEL "RTN","DGADDUTL",6,0) ADDRLOOP ; "RTN","DGADDUTL",7,0) W !! "RTN","DGADDUTL",8,0) K DIC,Y,DFN,USERSEL "RTN","DGADDUTL",9,0) S DIC="^DPT(",DIC(0)="AEMZQ",DIC("A")="Veteran Name/SSN: " D ^DIC "RTN","DGADDUTL",10,0) I $D(DTOUT)!($D(DUOUT)) Q "RTN","DGADDUTL",11,0) Q:Y'>0 "RTN","DGADDUTL",12,0) ; "RTN","DGADDUTL",13,0) S DFN=+Y,QUIT=0 "RTN","DGADDUTL",14,0) L +^DPT(DFN):3 E W !!,"Patient is being edited. Try again later." G ADDR "RTN","DGADDUTL",15,0) F D Q:QUIT "RTN","DGADDUTL",16,0) .; JAM - Patch DG*5.3*941 Modify prompt to add "Mailing" "RTN","DGADDUTL",17,0) .W !!,"Do you want to update the (P)ermanent Mailing Address, (T)emporary Mailing Address, or (B)oth? " "RTN","DGADDUTL",18,0) .R USERSEL:300 "RTN","DGADDUTL",19,0) .I '$T S USERSEL="^" "RTN","DGADDUTL",20,0) .I USERSEL["^"!(USERSEL="") S QUIT=1 Q "RTN","DGADDUTL",21,0) .S USERSEL=$TR(USERSEL,"ptb","PTB") "RTN","DGADDUTL",22,0) .I USERSEL'="P",USERSEL'="T",USERSEL'="B" D Q "RTN","DGADDUTL",23,0) ..W !,"Invalid selection!" "RTN","DGADDUTL",24,0) .I USERSEL="P"!(USERSEL="B") W ! D UPDATE(DFN,"PERM") "RTN","DGADDUTL",25,0) .I USERSEL="T"!(USERSEL="B") D UPDATE(DFN,"TEMP") "RTN","DGADDUTL",26,0) .S QUIT=1 "RTN","DGADDUTL",27,0) L -^DPT(DFN) "RTN","DGADDUTL",28,0) G ADDRLOOP "RTN","DGADDUTL",29,0) ADD(DFN) ; validate/edit Patient address (entry point for routine DGREG) "RTN","DGADDUTL",30,0) ; Input -- DFN "RTN","DGADDUTL",31,0) ; "RTN","DGADDUTL",32,0) ; DG*5.3*1040 - New variable DGADDFG to track called from entry point ADD "RTN","DGADDUTL",33,0) N RETVAL,ADDYN,DGADDFG S DGADDFG=1 "RTN","DGADDUTL",34,0) ;Display the permanent address (DG*5.3*851) "RTN","DGADDUTL",35,0) D DISPADD^DGADDUT2(DFN) "RTN","DGADDUTL",36,0) S (RETVAL,ADDYN)=0 "RTN","DGADDUTL",37,0) F D Q:ADDYN "RTN","DGADDUTL",38,0) .;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change prompt to Permanent Mailing Address: "RTN","DGADDUTL",39,0) .S ADDYN=$$ADDYN("Do you want to edit the Patient's Permanent Mailing Address") "RTN","DGADDUTL",40,0) .S RETVAL=ADDYN "RTN","DGADDUTL",41,0) .I ADDYN'=1,ADDYN'=2 S (ADDYN,RETVAL)=0 "RTN","DGADDUTL",42,0) .I 'ADDYN W !?5,"Enter 'YES' to edit Patient's Address or 'NO' to continue." "RTN","DGADDUTL",43,0) I ADDYN=1,$G(DFN)'="",$D(^DPT(DFN,0)) D "RTN","DGADDUTL",44,0) .D UPDATE(DFN,"PERM") "RTN","DGADDUTL",45,0) .; DG*5.3*1040 - Check if DGTMOT exists and return -1 "RTN","DGADDUTL",46,0) .I +$G(DGTMOT) S RETVAL=-1 "RTN","DGADDUTL",47,0) .E S RETVAL=1 "RTN","DGADDUTL",48,0) Q RETVAL "RTN","DGADDUTL",49,0) ADDYN(PROMPT) ; Yes/No Prompt to Edit/Validate Address "RTN","DGADDUTL",50,0) ; Input -- None "RTN","DGADDUTL",51,0) ; Output -- 1 = YES "RTN","DGADDUTL",52,0) ; 2 = NO "RTN","DGADDUTL",53,0) ; -1 = Aborted "RTN","DGADDUTL",54,0) ; "RTN","DGADDUTL",55,0) N % "RTN","DGADDUTL",56,0) W !,PROMPT "RTN","DGADDUTL",57,0) D YN^DICN "RTN","DGADDUTL",58,0) Q % "RTN","DGADDUTL",59,0) UPDATE(DFN,TYPE) ; Update the Address "RTN","DGADDUTL",60,0) ; Input -- TYPE = "PERM" for Permanent Address "RTN","DGADDUTL",61,0) ; = "TEMP" for Temporary Address "RTN","DGADDUTL",62,0) ; Output -- None "RTN","DGADDUTL",63,0) ; "RTN","DGADDUTL",64,0) I TYPE'="PERM",TYPE'="TEMP" Q "RTN","DGADDUTL",65,0) I TYPE="PERM" D "RTN","DGADDUTL",66,0) .W ! "RTN","DGADDUTL",67,0) .; JAM DG*5.3*941, Home and Office phone numbers not associated with Perm Address, so set FLG(1)=0 so we don't edit these fields here "RTN","DGADDUTL",68,0) .N FLG S FLG(1)=0,FLG(2)=1 "RTN","DGADDUTL",69,0) .D ADDRED(DFN,.FLG) "RTN","DGADDUTL",70,0) ; "RTN","DGADDUTL",71,0) I TYPE="TEMP" D "RTN","DGADDUTL",72,0) .D EDITTADR(DFN) "RTN","DGADDUTL",73,0) ; "RTN","DGADDUTL",74,0) Q "RTN","DGADDUTL",75,0) UPDDTTM(DFN,TYPE) ; Update the PATIENT file #2 with the current date and time "RTN","DGADDUTL",76,0) ; "RTN","DGADDUTL",77,0) D UPDDTTM^DGADDUT2(DFN,TYPE) "RTN","DGADDUTL",78,0) Q "RTN","DGADDUTL",79,0) ADDRED(DFN,FLG) ; Address Edit (Code copied from DGREGAED and modified) "RTN","DGADDUTL",80,0) ;Input: "RTN","DGADDUTL",81,0) ; DFN (required) - Internal Entry # of Patient File (#2) "RTN","DGADDUTL",82,0) ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details: "RTN","DGADDUTL",83,0) ; FLG(1) - if 1, let user edit phone numbers (field #.131 and #.132) "RTN","DGADDUTL",84,0) ; FLG(2) - if 1, display before & after address for user confirmation "RTN","DGADDUTL",85,0) N SRC,%,DGINPUT,I,X,Y "RTN","DGADDUTL",86,0) I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly "RTN","DGADDUTL",87,0) S SRC="ADDUTL" "RTN","DGADDUTL",88,0) D EN^DGREGAED(DFN,.FLG,SRC) "RTN","DGADDUTL",89,0) ; "RTN","DGADDUTL",90,0) ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting "RTN","DGADDUTL",91,0) I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!! "RTN","DGADDUTL",92,0) ; "RTN","DGADDUTL",93,0) ; Update the Date/Time Stamp "RTN","DGADDUTL",94,0) ;The next line was disabled to fix problem of Date/Time stamp being "RTN","DGADDUTL",95,0) ;updated even if no changes were made (DG*5.3*851). "RTN","DGADDUTL",96,0) ;D UPDDTTM(DFN,TYPE) "RTN","DGADDUTL",97,0) Q "RTN","DGADDUTL",98,0) GETPRIOR(DFN,DGPRIOR) ; Get prior address fields. "RTN","DGADDUTL",99,0) N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY "RTN","DGADDUTL",100,0) D GETS^DIQ(2,DFN_",",".111;.112;.113;.114;.115;.117;.1112;.131;.132;.121;.118;.119;.12;.122;.1171:.1173","I","DGCURR") "RTN","DGADDUTL",101,0) F DGN=.111,.112,.113,.114,.115,.117,.1112,.131,.132,.121,.118,.119,.12,.122,.1171,.1172,.1173 D "RTN","DGADDUTL",102,0) . S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I")) "RTN","DGADDUTL",103,0) M DGPRIOR=DGARRY("OLD") "RTN","DGADDUTL",104,0) Q "RTN","DGADDUTL",105,0) GETUPDTS(DFN,DGINPUT) ; Get current address fields. "RTN","DGADDUTL",106,0) N DGCURR,DGN,DGARRY "RTN","DGADDUTL",107,0) D GETS^DIQ(2,DFN_",",".118;.119;.12;.122","I","DGCURR") "RTN","DGADDUTL",108,0) F DGN=.118,.119,.12,.122 D "RTN","DGADDUTL",109,0) . S DGARRY("NEW",DGN)=$G(DGCURR(2,DFN_",",DGN,"I")) "RTN","DGADDUTL",110,0) M DGINPUT=DGARRY("NEW") "RTN","DGADDUTL",111,0) Q "RTN","DGADDUTL",112,0) FILEYN(DGOLD,DGNEW) ; Determine whether or not to file to #301.7 "RTN","DGADDUTL",113,0) N RETVAL "RTN","DGADDUTL",114,0) S RETVAL=0 "RTN","DGADDUTL",115,0) D "RTN","DGADDUTL",116,0) .I DGOLD(.111)'=$G(DGNEW(.111)) S RETVAL=1 Q "RTN","DGADDUTL",117,0) .I DGOLD(.112)'=$G(DGNEW(.112)) S RETVAL=1 Q "RTN","DGADDUTL",118,0) .I DGOLD(.113)'=$G(DGNEW(.113)) S RETVAL=1 Q "RTN","DGADDUTL",119,0) .I DGOLD(.114)'=$G(DGNEW(.114)) S RETVAL=1 Q "RTN","DGADDUTL",120,0) .I DGOLD(.115)'=$P($G(DGNEW(.115)),"^",2) S RETVAL=1 Q "RTN","DGADDUTL",121,0) .I DGOLD(.1112)'=$G(DGNEW(.1112)) S RETVAL=1 Q "RTN","DGADDUTL",122,0) .I DGOLD(.117)'=$P($G(DGNEW(.117)),"^",2) S RETVAL=1 Q "RTN","DGADDUTL",123,0) .I DGOLD(.131)'=$G(DGNEW(.131)) S RETVAL=1 Q "RTN","DGADDUTL",124,0) .I DGOLD(.1171)'=$G(DGNEW(.1171)) S RETVAL=1 Q "RTN","DGADDUTL",125,0) .I DGOLD(.1172)'=$G(DGNEW(.1172)) S RETVAL=1 Q "RTN","DGADDUTL",126,0) .I DGOLD(.1173)'=$P($G(DGNEW(.1173)),"^",2) S RETVAL=1 Q "RTN","DGADDUTL",127,0) .I DGOLD(.121)'=$G(DGNEW(.121)) S RETVAL=1 Q "RTN","DGADDUTL",128,0) Q RETVAL "RTN","DGADDUTL",129,0) FOREIGN(DFN,CIEN,FILE,FIELD,COUNTRY) ; "RTN","DGADDUTL",130,0) ; ** NOTE we have to default the value for "US" into the prompt if it is blank "RTN","DGADDUTL",131,0) N FORGN,DA,DIR,DTOUT,DUOUT,DIROUT,DONE,INDX "RTN","DGADDUTL",132,0) S:'$G(FILE) FILE=2 I '$G(FIELD) S FIELD=.1173 "RTN","DGADDUTL",133,0) S DIR(0)=FILE_","_FIELD,DONE=0 S:DFN DA=DFN "RTN","DGADDUTL",134,0) S DIR("B")=$E($$CNTRYI^DGADDUTL(CIEN),1,19) I DIR("B")=-1 S DIR("B")="UNKNOWN COUNTRY" "RTN","DGADDUTL",135,0) F D Q:DONE "RTN","DGADDUTL",136,0) . D ^DIR "RTN","DGADDUTL",137,0) . I $D(DTOUT) S DONE=1,FORGN=-1 Q "RTN","DGADDUTL",138,0) . I $D(DUOUT)!$D(DIROUT) W !,"EXIT NOT ALLOWED" Q "RTN","DGADDUTL",139,0) . I $D(DIRUT) W !,"This is a required response." Q "RTN","DGADDUTL",140,0) . S COUNTRY=$P($G(Y),"^",2),FORGN=$$FORIEN($P($G(Y),"^")),DONE=1 "RTN","DGADDUTL",141,0) Q FORGN "RTN","DGADDUTL",142,0) UPDADDLG(DFN,DGPRIOR,DGINPUT) ; Update the IVM ADDRESS CHANGE LOG file #301.7 "RTN","DGADDUTL",143,0) ; "RTN","DGADDUTL",144,0) D UPDADDLG^DGADDUT2(DFN,.DGPRIOR,.DGINPUT) "RTN","DGADDUTL",145,0) Q "RTN","DGADDUTL",146,0) EDITTADR(DFN) ; Edit Temporary Address "RTN","DGADDUTL",147,0) N DGPRIOR,DGCH,DGRPAN,DGDR,DGRPS "RTN","DGADDUTL",148,0) I $G(DFN)="" Q "RTN","DGADDUTL",149,0) ;I ($G(DFN)'?.N) Q "RTN","DGADDUTL",150,0) ; "RTN","DGADDUTL",151,0) ; Get the current Temporary Address and display it "RTN","DGADDUTL",152,0) D GETTADR(DFN,.DGPRIOR) "RTN","DGADDUTL",153,0) D DISPTADR(DFN,.DGPRIOR) "RTN","DGADDUTL",154,0) W !! "RTN","DGADDUTL",155,0) ; "RTN","DGADDUTL",156,0) I '$G(DGADDFG) N DGTMOT S DGTMOT=0 ; DG*5.3*1040 - New only coming from entry point UPDATE directly "RTN","DGADDUTL",157,0) ; "RTN","DGADDUTL",158,0) ; JAM - Patch DG*5.3*941 - Temporary Mailing Address is editable via screen 1.1 group 3 (from screen 1 group 5) "RTN","DGADDUTL",159,0) ;S DGCH=5,DGRPAN="1,2,3,4,5,",DGDR="",DGRPS=1 "RTN","DGADDUTL",160,0) S DGCH=3,DGRPAN="1,2,3,4,5",DGDR="",DGRPS=1.1 "RTN","DGADDUTL",161,0) D CHOICE^DGRPP "RTN","DGADDUTL",162,0) D ^DGRPE "RTN","DGADDUTL",163,0) ; DG*5.3*1040; jam; If timeout and this is a direct call to UPDATE, clear the screen prior to quitting "RTN","DGADDUTL",164,0) I $G(DGTMOT),'$G(DGADDFG) W @IOF,!!! Q "RTN","DGADDUTL",165,0) ; Update the Date/Time Stamp "RTN","DGADDUTL",166,0) D UPDDTTM(DFN,TYPE) "RTN","DGADDUTL",167,0) Q "RTN","DGADDUTL",168,0) GETTADR(DFN,DGPRIOR) ; Get prior temporary address fields. "RTN","DGADDUTL",169,0) N DGCURR,DGN,DGARRY,DGCIEN,DGST,DGCNTY "RTN","DGADDUTL",170,0) D GETS^DIQ(2,DFN_",",".1211;.1212;.1213;.1214;.1215;.1216;.1217;.1218;.12105;.1219;.12111;.12112;.12113;.12114;.1221:.1223","I","DGCURR") "RTN","DGADDUTL",171,0) F DGN=.1211,.1212,.1213,.1214,.1215,.1216,.1217,.1218,.12105,.1219,.12111,.12112,.12113,.12114,.1221,.1222,.1223 D "RTN","DGADDUTL",172,0) .S DGARRY("OLD",DGN)=$G(DGCURR(2,DFN_",",DGN,"I")) "RTN","DGADDUTL",173,0) M DGPRIOR=DGARRY("OLD") "RTN","DGADDUTL",174,0) Q "RTN","DGADDUTL",175,0) DISPTADR(DFN,DGARRY) ; Display Temporary Address "RTN","DGADDUTL",176,0) N DGADRACT,DGADR1,DGADR2,DGADR3,DGCITY,DGSTATE,DGZIP "RTN","DGADDUTL",177,0) N DGCOUNTY,DGPHONE,DGFROMDT,DGTODT,DGPROV,DGPCODE,DGCNTRY,DGFORN "RTN","DGADDUTL",178,0) ; "RTN","DGADDUTL",179,0) S DGADRACT=$G(DGARRY(.12105)) "RTN","DGADDUTL",180,0) S DGADR1=$G(DGARRY(.1211)) "RTN","DGADDUTL",181,0) S DGADR2=$G(DGARRY(.1212)) "RTN","DGADDUTL",182,0) S DGADR3=$G(DGARRY(.1213)) "RTN","DGADDUTL",183,0) S DGCITY=$G(DGARRY(.1214)) "RTN","DGADDUTL",184,0) S DGSTATE=$G(DGARRY(.1215)) "RTN","DGADDUTL",185,0) S DGZIP=$G(DGARRY(.1216)) "RTN","DGADDUTL",186,0) S DGCOUNTY=$G(DGARRY(.12111)) "RTN","DGADDUTL",187,0) I DGCOUNTY'="",DGSTATE'="",$D(^DIC(5,DGSTATE,1,DGCOUNTY,0)) D "RTN","DGADDUTL",188,0) .S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_$S($P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)'="":"("_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4)_")",1:"") "RTN","DGADDUTL",189,0) ;changing to remove display of empty (), will only display if a code is in the 4th piece of the state file-Patch 872 "RTN","DGADDUTL",190,0) ;S DGCOUNTY=$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^")_"( "_$P(^DIC(5,DGSTATE,1,DGCOUNTY,0),"^",4) "RTN","DGADDUTL",191,0) I DGADRACT'="Y" S DGCOUNTY="NOT APPLICABLE" "RTN","DGADDUTL",192,0) I DGSTATE'="",$D(^DIC(5,DGSTATE,0)) S DGSTATE=$P(^DIC(5,DGSTATE,0),"^",2) "RTN","DGADDUTL",193,0) S DGPROV=$G(DGARRY(.1221)) "RTN","DGADDUTL",194,0) S DGPCODE=$G(DGARRY(.1222)) "RTN","DGADDUTL",195,0) S DGCNTRY=$G(DGARRY(.1223)) "RTN","DGADDUTL",196,0) S DGFORN=$$FORIEN(DGCNTRY) "RTN","DGADDUTL",197,0) I DGCNTRY]"" S DGCNTRY=$$CNTRYI(DGCNTRY) "RTN","DGADDUTL",198,0) S DGPHONE=$G(DGARRY(.1219)) "RTN","DGADDUTL",199,0) S DGFROMDT=$$FMTE^XLFDT($G(DGARRY(.1217))) "RTN","DGADDUTL",200,0) S DGTODT=$$FMTE^XLFDT($G(DGARRY(.1218))) "RTN","DGADDUTL",201,0) ; "RTN","DGADDUTL",202,0) ;jam DG*5.3*925 RM#788099 Add/Edit Residential address - Change field label to Temporary Mailing Address: "RTN","DGADDUTL",203,0) W !!,"Temporary Mailing Address: " "RTN","DGADDUTL",204,0) I DGADRACT="Y" D "RTN","DGADDUTL",205,0) .W:DGADR1'="" !?9,DGADR1 "RTN","DGADDUTL",206,0) .W:DGADR2'="" !?9,DGADR2 "RTN","DGADDUTL",207,0) .W:DGADR3'="" !?9,DGADR3 "RTN","DGADDUTL",208,0) .I DGFORN=0 D "RTN","DGADDUTL",209,0) ..W !?9,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"") "RTN","DGADDUTL",210,0) .;I DGFORN W !?8,$S(DGPCODE'="":DGPCODE,1:"")_" "_$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"") ;DG*1010 comment out "RTN","DGADDUTL",211,0) .I DGFORN W !?8,$S(DGCITY'="":DGCITY,1:"")_$S(DGCITY'="":",",1:" ")_$S(DGPROV'="":DGPROV,1:"")_" "_$S(DGPCODE'="":DGPCODE,1:"") ;DG*1010 - display postal code last "RTN","DGADDUTL",212,0) ;commenting out, causes address to print 2x. Patch 872 "RTN","DGADDUTL",213,0) ;W !?9,$S(DGCITY'="":DGCITY,1:"")_","_$S(DGSTATE'="":DGSTATE,1:"")_" "_$S(DGZIP'="":DGZIP,1:"") "RTN","DGADDUTL",214,0) ;Removing lines from dot structure Patch 872 "RTN","DGADDUTL",215,0) W !," County: "_DGCOUNTY "RTN","DGADDUTL",216,0) W !," Phone: "_DGPHONE "RTN","DGADDUTL",217,0) W !,"From/To: "_$P(DGFROMDT,",")_","_$P(DGFROMDT,", ",2)_"-"_$P(DGTODT,",")_","_$P(DGTODT,", ",2) "RTN","DGADDUTL",218,0) ; "RTN","DGADDUTL",219,0) I $G(DGARRY(.12105))="N" D "RTN","DGADDUTL",220,0) .W:$G(DGARRY(.1211))="" !?9,"NO TEMPORARY ADDRESS" "RTN","DGADDUTL",221,0) .W:$G(DGARRY(.1212))="" !?9,"" "RTN","DGADDUTL",222,0) .W !," County: NOT APPLICABLE" "RTN","DGADDUTL",223,0) .W !," Phone: NOT APPLICABLE" "RTN","DGADDUTL",224,0) .W !,"From/To: NOT APPLICABLE" "RTN","DGADDUTL",225,0) Q "RTN","DGADDUTL",226,0) COUNTRY(DGC) ; "RTN","DGADDUTL",227,0) ;where DGC is the external value of the country "RTN","DGADDUTL",228,0) ;return value is in upper case display mode "RTN","DGADDUTL",229,0) ;if DGC is invalid, return -1 "RTN","DGADDUTL",230,0) N DGCC,DGIEN "RTN","DGADDUTL",231,0) ; if input is NULL change to US "RTN","DGADDUTL",232,0) I $G(DGC)="" S DGC="USA" "RTN","DGADDUTL",233,0) ; Get IEN from B index, error if not found "RTN","DGADDUTL",234,0) S DGIEN=$O(^HL(779.004,"B",DGC,"")) Q:DGIEN']"" -1 "RTN","DGADDUTL",235,0) ; xlate IEN to POSTAL NAME "RTN","DGADDUTL",236,0) S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3) "RTN","DGADDUTL",237,0) ; if POSTAL NAME = "" return DESCRIPTION "RTN","DGADDUTL",238,0) I DGCC="" D "RTN","DGADDUTL",239,0) . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2)) "RTN","DGADDUTL",240,0) Q DGCC "RTN","DGADDUTL",241,0) FOR(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is not valid "RTN","DGADDUTL",242,0) ; DGC is the external value of the country (.01 field of file 779.004) "RTN","DGADDUTL",243,0) N DGFOR "RTN","DGADDUTL",244,0) S DGFOR=0 "RTN","DGADDUTL",245,0) I $G(DGC)="" Q DGFOR "RTN","DGADDUTL",246,0) I '$D(^HL(779.004,"B",DGC)) Q -1 "RTN","DGADDUTL",247,0) I DGC'="USA" S DGFOR=1 "RTN","DGADDUTL",248,0) Q DGFOR "RTN","DGADDUTL",249,0) CNTRYI(DGIEN) ;where DGC is the internal value of the country "RTN","DGADDUTL",250,0) ;return DGC as the display value for the country "RTN","DGADDUTL",251,0) ;if the input value is not a valid IEN, return -1 "RTN","DGADDUTL",252,0) ;if the input value is null, return null "RTN","DGADDUTL",253,0) N DGCC "RTN","DGADDUTL",254,0) I $G(DGIEN)="" Q "" "RTN","DGADDUTL",255,0) I '$D(^HL(779.004,DGIEN,0)) Q -1 "RTN","DGADDUTL",256,0) ; xlate IEN to POSTAL NAME "RTN","DGADDUTL",257,0) S DGCC=$P(^HL(779.004,DGIEN,"SDS"),U,3) "RTN","DGADDUTL",258,0) ; if POSTAL NAME = "" return DESCRIPTION "RTN","DGADDUTL",259,0) I DGCC="" D "RTN","DGADDUTL",260,0) . S DGCC=$$UPPER^DGUTL($P(^HL(779.004,DGIEN,0),U,2)) "RTN","DGADDUTL",261,0) Q DGCC "RTN","DGADDUTL",262,0) FORIEN(DGC) ;returns a 1 if address is foreign, a 0 if domestic, -1 if DGC is invalid "RTN","DGADDUTL",263,0) ;DGC is the IEN of the country file (#779.004) "RTN","DGADDUTL",264,0) N DGFOR "RTN","DGADDUTL",265,0) S DGFOR=0 "RTN","DGADDUTL",266,0) I $G(DGC)="" Q DGFOR "RTN","DGADDUTL",267,0) I DGC'?1.3N Q -1 "RTN","DGADDUTL",268,0) I '$D(^HL(779.004,DGC,0)) Q -1 "RTN","DGADDUTL",269,0) I DGC]"",(DGC'=$O(^HL(779.004,"B","USA",""))) S DGFOR=1 "RTN","DGADDUTL",270,0) Q DGFOR "RTN","DGADDVAL") 0^14^B11543186^B11247230 "RTN","DGADDVAL",1,0) DGADDVAL ;ALB/JAM - UAM Address Validation ;28 May 2020 10:33 AM "RTN","DGADDVAL",2,0) ;;5.3;Registration;**1014,1040**;Aug 13, 1993;Build 15 "RTN","DGADDVAL",3,0) ; "RTN","DGADDVAL",4,0) EN(DGINPUT,DGTYPE) ; Main entry point "RTN","DGADDVAL",5,0) ; Input: DGINPUT (Required, pass by reference) - Array containing the address to be validated "RTN","DGADDVAL",6,0) ; DGTYPE (optional) - Address Type: "R"-Residential "C"-Confidential "P"-Permanent (default) "RTN","DGADDVAL",7,0) ; Output: DGINPUT (Pass by reference) - Array will contain the address accepted by the user "RTN","DGADDVAL",8,0) ; Return: 0 - error has been encountered "RTN","DGADDVAL",9,0) ; 1 - validation is completed and DGINPUT contains the accepted address "RTN","DGADDVAL",10,0) ; "RTN","DGADDVAL",11,0) ; Format of DGINPUT array "RTN","DGADDVAL",12,0) ; DGINPUT(field#)=VALUE "RTN","DGADDVAL",13,0) ; "RTN","DGADDVAL",14,0) ; Note: For Residential and Perm Addresses: "RTN","DGADDVAL",15,0) ; State VALUE = "STATENAME^STATECODE" "RTN","DGADDVAL",16,0) ; Country VALUE = "COUNTRY^COUNTRYCODE" "RTN","DGADDVAL",17,0) ; County VALUE = "COUNTY^COUNTYCODE "RTN","DGADDVAL",18,0) ; For Confidential Addresses: "RTN","DGADDVAL",19,0) ; State VALUE = "STATECODE^STATENAME" "RTN","DGADDVAL",20,0) ; Country VALUE = "COUNTRYCODE^COUNTRY" "RTN","DGADDVAL",21,0) ; County VALUE = "COUNTYCODE^COUNTY "RTN","DGADDVAL",22,0) ; "RTN","DGADDVAL",23,0) N DGCNT,DGADDR,DGFLDS,DGFORGN,DGCTRYCD,DGSTR,DGX,DGRECS,DGSELADD,DGSTAT,DGSTATECD,DGTMOT "RTN","DGADDVAL",24,0) ; "RTN","DGADDVAL",25,0) ; Set up string of address field numbers - Format: "RTN","DGADDVAL",26,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGADDVAL",27,0) S DGFLDS=".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173" ; Permanent Address fields "RTN","DGADDVAL",28,0) I $G(DGTYPE)="R" S DGFLDS=".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573" ; Residential address fields "RTN","DGADDVAL",29,0) I $G(DGTYPE)="C" S DGFLDS=".1411,.1412,.1413,.1414,.1415,.14111,.1416,.14114,.14115,.14116" ; Confidential address fields "RTN","DGADDVAL",30,0) ; "RTN","DGADDVAL",31,0) ; All addresses are placed in the DGADDR array for user selection "RTN","DGADDVAL",32,0) ; First address displayed is the address DGINPUT "RTN","DGADDVAL",33,0) S DGCNT=1 "RTN","DGADDVAL",34,0) M DGADDR(DGCNT)=DGINPUT "RTN","DGADDVAL",35,0) ; Normalize the Country and State entries for Conf address in DGADDR so the format is the same for all addresses in DGADDR array "RTN","DGADDVAL",36,0) I DGTYPE="C" D "RTN","DGADDVAL",37,0) . ; State may not be defined "RTN","DGADDVAL",38,0) . I $D(DGADDR(1,$P(DGFLDS,",",5))) S DGX=DGADDR(1,$P(DGFLDS,",",5)),DGADDR(1,$P(DGFLDS,",",5))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",39,0) . S DGX=DGADDR(1,$P(DGFLDS,",",10)),DGADDR(1,$P(DGFLDS,",",10))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",40,0) ; Capture the State code passed in "RTN","DGADDVAL",41,0) S DGCTRYCD=$P(DGADDR(1,$P(DGFLDS,",",10)),"^",2) "RTN","DGADDVAL",42,0) ; Get flag for domestic/foreign address "RTN","DGADDVAL",43,0) S DGFORGN=0 "RTN","DGADDVAL",44,0) S DGFORGN=$$FORIEN^DGADDUTL(DGCTRYCD) "RTN","DGADDVAL",45,0) I 'DGFORGN S DGSTATECD=$P(DGADDR(1,$P(DGFLDS,",",5)),"^",2) "RTN","DGADDVAL",46,0) ; "RTN","DGADDVAL",47,0) ; Call the validation service "RTN","DGADDVAL",48,0) S DGSTAT=$$EN^DGUAMWS(.DGADDR,DGFLDS,DGFORGN) ; DGADDR is updated with address validation results "RTN","DGADDVAL",49,0) I +DGSTAT=0 QUIT DGSTAT "RTN","DGADDVAL",50,0) ; get total records returned. Subtract one for the original. "RTN","DGADDVAL",51,0) S DGRECS=$O(DGADDR(""),-1)-1 "RTN","DGADDVAL",52,0) F DGX=1:1:DGRECS D "RTN","DGADDVAL",53,0) . S DGCNT=DGCNT+1 "RTN","DGADDVAL",54,0) . ; Store in this array entry the same country that was passed in "RTN","DGADDVAL",55,0) . S DGADDR(DGCNT,$P(DGFLDS,",",10))=DGADDR(1,$P(DGFLDS,",",10)) "RTN","DGADDVAL",56,0) . I 'DGFORGN D "RTN","DGADDVAL",57,0) . . ; Store the same county that was passed in "RTN","DGADDVAL",58,0) . . S DGADDR(DGCNT,$P(DGFLDS,",",6))=DGADDR(1,$P(DGFLDS,",",6)) "RTN","DGADDVAL",59,0) ; "RTN","DGADDVAL",60,0) ; Call DGEN ADDR VAL list to show addresses and allow user selection "RTN","DGADDVAL",61,0) S DGADDR=DGCNT "RTN","DGADDVAL",62,0) ; DG*5.3*1040; Add DTMOUT param for Timeout in the subroutine "RTN","DGADDVAL",63,0) D EN^DGADDLST(DFN,DGFLDS,.DGADDR,.DGSELADD,.DGTMOT) "RTN","DGADDVAL",64,0) ; DG*5.3*1040; If DGTMOT set, return -1 to flag that a timeout occurred "RTN","DGADDVAL",65,0) I +$G(DGTMOT) Q -1 "RTN","DGADDVAL",66,0) ; Move selected address into DGINPUT array "RTN","DGADDVAL",67,0) M DGINPUT=DGSELADD "RTN","DGADDVAL",68,0) ; Put the State and Country fields back in DGINPUT to the format used for Conf addresses "RTN","DGADDVAL",69,0) I DGTYPE="C" D "RTN","DGADDVAL",70,0) . I $D(DGADDR(1,$P(DGFLDS,",",5))) D "RTN","DGADDVAL",71,0) . . S DGX=DGINPUT($P(DGFLDS,",",5)),DGINPUT($P(DGFLDS,",",5))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",72,0) . . ; If the State code is empty, put the original State code in the array - Confidential Address needs the State code to file "RTN","DGADDVAL",73,0) . . I $P(DGINPUT($P(DGFLDS,",",5)),"^",1)="" S $P(DGINPUT($P(DGFLDS,",",5)),"^",1)=DGSTATECD "RTN","DGADDVAL",74,0) . S DGX=DGINPUT($P(DGFLDS,",",10)),DGINPUT($P(DGFLDS,",",10))=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGADDVAL",75,0) Q 1 "RTN","DGENDBS") 0^12^B5434355^B5347625 "RTN","DGENDBS",1,0) DGENDBS ;ALB/RMO/CJM,JAM - Database Server Utilities; [ 03/23/95 11:08 AM ] "RTN","DGENDBS",2,0) ;;5.3;Registration;**122,147,182,1040**;08/13/93;Build 15 "RTN","DGENDBS",3,0) ; "RTN","DGENDBS",4,0) UPD(FILE,DGENDA,DATA,ERROR) ;File data into an existing record. "RTN","DGENDBS",5,0) ; Input: "RTN","DGENDBS",6,0) ; FILE - File or sub-file number "RTN","DGENDBS",7,0) ; DGENDA - New name for traditional DA array, with same meaning. "RTN","DGENDBS",8,0) ; Pass by reference. "RTN","DGENDBS",9,0) ; DATA - Data array to file (pass by reference) "RTN","DGENDBS",10,0) ; Format: DATA()= "RTN","DGENDBS",11,0) ; "RTN","DGENDBS",12,0) ; Output: "RTN","DGENDBS",13,0) ; Function Value - 0=error and 1=no error "RTN","DGENDBS",14,0) ; ERROR - optional error message - if needed, pass by reference "RTN","DGENDBS",15,0) ; "RTN","DGENDBS",16,0) ; Example: To update a record in subfile 2.0361 in record with ien=353, "RTN","DGENDBS",17,0) ; subrecord ien=68, with the field .01 value = 21: "RTN","DGENDBS",18,0) ; S DATA(.01)=21,DGENDA=68,DGENDA(1)=353 I $$UPD^DGENDBS(2.0361,.DGENDA,.DATA,.ERROR) W !,"DONE" "RTN","DGENDBS",19,0) ; "RTN","DGENDBS",20,0) ; DG*5,3*1040;jam; Add New of DTOUT to protect it from FILE^DIE which will kill this variable. "RTN","DGENDBS",21,0) N FDA,FIELD,IENS,ERRORS,DTOUT "RTN","DGENDBS",22,0) ; "RTN","DGENDBS",23,0) ;IENS - Internal Entry Number String defined by FM "RTN","DGENDBS",24,0) ;FDA - the FDA array as defined by FM "RTN","DGENDBS",25,0) ; "RTN","DGENDBS",26,0) I '$G(DGENDA) S ERROR="IEN OF RECORD TO BE UPDATED NOT SPECIFIED" Q 0 "RTN","DGENDBS",27,0) S IENS=$$IENS^DILF(.DGENDA) "RTN","DGENDBS",28,0) S FIELD=0 "RTN","DGENDBS",29,0) F S FIELD=$O(DATA(FIELD)) Q:'FIELD D "RTN","DGENDBS",30,0) .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD)) "RTN","DGENDBS",31,0) D FILE^DIE("K","FDA","ERRORS(1)") "RTN","DGENDBS",32,0) I +$G(DIERR) D "RTN","DGENDBS",33,0) .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1)) "RTN","DGENDBS",34,0) E D "RTN","DGENDBS",35,0) .S ERROR="" "RTN","DGENDBS",36,0) ; "RTN","DGENDBS",37,0) I $S(+$G(DIERR):0,1:1) D CLEAN^DILF Q 1 "RTN","DGENDBS",38,0) E D CLEAN^DILF Q 0 "RTN","DGENDBS",39,0) ; "RTN","DGENDBS",40,0) ADD(FILE,DGENDA,DATA,ERROR,IEN) ; "RTN","DGENDBS",41,0) ;Description: Creates a new record and files the data. "RTN","DGENDBS",42,0) ; Input: "RTN","DGENDBS",43,0) ; FILE - File or sub-file number "RTN","DGENDBS",44,0) ; DGENDA - New name for traditional FileMan DA array with same "RTN","DGENDBS",45,0) ; meaning. Pass by reference. Only needed if adding to a "RTN","DGENDBS",46,0) ; subfile. "RTN","DGENDBS",47,0) ; DATA - Data array to file, pass by reference "RTN","DGENDBS",48,0) ; Format: DATA()= "RTN","DGENDBS",49,0) ; IEN - internal entry number to use (optional) "RTN","DGENDBS",50,0) ; "RTN","DGENDBS",51,0) ; Output: "RTN","DGENDBS",52,0) ; Function Value - If no error then it returns the ien of the created record, else returns NULL. "RTN","DGENDBS",53,0) ; DGENDA - returns the ien of the new record, NULL if none created. If needed, pass by reference. "RTN","DGENDBS",54,0) ; ERROR - optional error message - if needed, pass by reference "RTN","DGENDBS",55,0) ; "RTN","DGENDBS",56,0) ; Example: To add a record in subfile 2.0361 in the record with ien=353 "RTN","DGENDBS",57,0) ; with the field .01 value = 21: "RTN","DGENDBS",58,0) ; S DATA(.01)=21,DGENDA(1)=353 I $$ADD^DGENDBS(2.0361,.DGENDA,.DATA) W !,"DONE" "RTN","DGENDBS",59,0) ; "RTN","DGENDBS",60,0) ; Example: If creating a record not in a subfile, would look like this: "RTN","DGENDBS",61,0) ; S DATA(.01)=21 I $$ADD^DGENDBS(867,,.DATA) W !,"DONE" "RTN","DGENDBS",62,0) ; "RTN","DGENDBS",63,0) N FDA,FIELD,IENA,IENS,ERRORS "RTN","DGENDBS",64,0) ; "RTN","DGENDBS",65,0) ;IENS - Internal Entry Number String defined by FM "RTN","DGENDBS",66,0) ;IENA - the Internal Entry Numebr Array defined by FM "RTN","DGENDBS",67,0) ;FDA - the FDA array defined by FM "RTN","DGENDBS",68,0) ;IEN - the ien of the new record "RTN","DGENDBS",69,0) ; "RTN","DGENDBS",70,0) S DGENDA="+1" "RTN","DGENDBS",71,0) S IENS=$$IENS^DILF(.DGENDA) "RTN","DGENDBS",72,0) S FIELD=0 "RTN","DGENDBS",73,0) F S FIELD=$O(DATA(FIELD)) Q:'FIELD D "RTN","DGENDBS",74,0) .S FDA(FILE,IENS,FIELD)=$G(DATA(FIELD)) "RTN","DGENDBS",75,0) I $G(IEN) S IENA(1)=IEN "RTN","DGENDBS",76,0) D UPDATE^DIE("","FDA","IENA","ERRORS(1)") "RTN","DGENDBS",77,0) I +$G(DIERR) D "RTN","DGENDBS",78,0) .S ERROR=$G(ERRORS(1,"DIERR",1,"TEXT",1)) "RTN","DGENDBS",79,0) .S IEN="" "RTN","DGENDBS",80,0) E D "RTN","DGENDBS",81,0) .S IEN=IENA(1) "RTN","DGENDBS",82,0) .S ERROR="" "RTN","DGENDBS",83,0) D CLEAN^DILF "RTN","DGENDBS",84,0) S DGENDA=IEN "RTN","DGENDBS",85,0) Q IEN "RTN","DGENDBS",86,0) ; "RTN","DGENDBS",87,0) TESTVAL(FILE,FIELD,VALUE) ; "RTN","DGENDBS",88,0) ;Description: returns 1 if VALUE is a valid value for FIELD in FILE "RTN","DGENDBS",89,0) ; "RTN","DGENDBS",90,0) Q:(('$G(FILE))!('$G(FIELD))) 0 "RTN","DGENDBS",91,0) ; "RTN","DGENDBS",92,0) N DISPLAY,VALID,RESULT "RTN","DGENDBS",93,0) S VALID=1 "RTN","DGENDBS",94,0) ; "RTN","DGENDBS",95,0) ;if there is no external value then it is not valid "RTN","DGENDBS",96,0) S DISPLAY=$$EXTERNAL^DILFD(FILE,FIELD,"F",VALUE) "RTN","DGENDBS",97,0) I (DISPLAY="") S VALID=0 "RTN","DGENDBS",98,0) ; "RTN","DGENDBS",99,0) I VALID,$$GET1^DID(FILE,FIELD,"","TYPE")'["POINTER" D "RTN","DGENDBS",100,0) .D CHK^DIE(FILE,FIELD,,VALUE,.RESULT) I RESULT="^" S VALID=0 Q "RTN","DGENDBS",101,0) Q VALID "RTN","DGLOCK") 0^15^B53950031^B53456898 "RTN","DGLOCK",1,0) DGLOCK ;ALB/MRL,ERC,BAJ,LBD - PATIENT FILE DATA EDIT CHECKS ; 2/14/11 4:36pm "RTN","DGLOCK",2,0) ;;5.3;Registration;**108,161,247,485,672,673,688,754,797,1040**;Aug 13, 1993;Build 15 "RTN","DGLOCK",3,0) FFP ; DGFFP Access key required "RTN","DGLOCK",4,0) I '$D(^XUSEC("DGFFP ACCESS",DUZ)) D EN^DDIOL("Fugitive Felon Key required to edit this field.","","!!?4") K X "RTN","DGLOCK",5,0) Q "RTN","DGLOCK",6,0) EK ;EKey Rqrd "RTN","DGLOCK",7,0) I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !?4,$C(7),"Eligibility Key required to edit this field." K X "RTN","DGLOCK",8,0) Q "RTN","DGLOCK",9,0) EV ;EK rqrd if Elig Ver "RTN","DGLOCK",10,0) I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D EN^DDIOL("Eligibility verified...Eligibility Key required to edit this field.","","!?4") K X "RTN","DGLOCK",11,0) Q "RTN","DGLOCK",12,0) EV2 ;if elig is ver Discharged Due to Disability can't be edited - DG 672 "RTN","DGLOCK",13,0) ;if elig is ver P&T and P&T Eff Date can't be edited - DG*5.3*688 "RTN","DGLOCK",14,0) I $D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" D "RTN","DGLOCK",15,0) . I $P(^DPT(DFN,.361),U,3)'="H" Q "RTN","DGLOCK",16,0) . D EN^DDIOL("Eligibility verified at the HEC...NO EDITING!","","!?4") K X "RTN","DGLOCK",17,0) Q "RTN","DGLOCK",18,0) SV ;EK Rqrd if Svc Rcrd Ver "RTN","DGLOCK",19,0) I "NU"'[$E(X) D VET Q:'$D(X) "RTN","DGLOCK",20,0) SV1 I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.32)) I $P(^(.32),U,2)]"" D EN^DDIOL("Service Record verfied...Eligibility Key required to edit this field.","","!?4") K X "RTN","DGLOCK",21,0) Q "RTN","DGLOCK",22,0) MV ;EK Rqrd if Money Ver "RTN","DGLOCK",23,0) I "NU"'[$E(X) D VET Q:'$D(X) "RTN","DGLOCK",24,0) I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.3)) I $P(^(.3),U,6)]"" W !?4,$C(7),"Monetary Benefits verified...Eligibility Key required to edit this field." K X "RTN","DGLOCK",25,0) Q "RTN","DGLOCK",26,0) VET ;Veteran "RTN","DGLOCK",27,0) S DGVV=$S($D(^DPT(DFN,"TYPE")):^("TYPE"),1:""),DGVV=$S($D(^DG(391,+DGVV,0)):$P(^(0),"^",2),1:"") "RTN","DGLOCK",28,0) I $D(^DPT(DFN,"VET")),^("VET")'="Y",'DGVV D EN^DDIOL("Applicant is NOT a veteran!!","","!?4") K X "RTN","DGLOCK",29,0) K DGVV Q "RTN","DGLOCK",30,0) VAGE ;Vet Age "RTN","DGLOCK",31,0) S DGDATA=X,X1=DT,X2=$S($D(DFN):$P(^DPT(DFN,0),U,3),1:DPTIDS(.03)) S X=$E(X1,1,3)-$E(X2,1,3)-($E(X1,4,7)<$E(X2,4,7)) "RTN","DGLOCK",32,0) I X<17 W !?4,$C(7),"Applicant is TOO YOUNG to be a veteran...ONLY ",X," YEARS OLD!!",!?4,"See your supervisor if you require assistance." K X,X1,X2,DGDATA Q "RTN","DGLOCK",33,0) S X=DGDATA K X1,X2,DGDATA Q "RTN","DGLOCK",34,0) AO ;Agent Orange "RTN","DGLOCK",35,0) D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,2)'="Y":1,1:0) W !?4,$C(7),"Exposure to Agent Orange not indicated...NO EDITING!" K X "RTN","DGLOCK",36,0) Q "RTN","DGLOCK",37,0) EC ;SW Asia Contaminants - name change from Env. Contam. DG*5.3*688 "RTN","DGLOCK",38,0) D SV I $D(X),$S('$D(^DPT(DFN,.322)):1,$P(^(.322),U,13)'="Y":1,1:0) W !?4,$C(7),"Southwest Asia Conditions not indicated...NO EDITING!" K X "RTN","DGLOCK",39,0) I $D(X) I X<2900802 K X W !?4,$C(7),"Date must be on or after 8/2/1990!" "RTN","DGLOCK",40,0) Q "RTN","DGLOCK",41,0) COM ;Combat "RTN","DGLOCK",42,0) D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,11)'="Y":1,1:0) W !?4,$C(7),"Service in Combat Zone not indicated...NO EDITING!" K X "RTN","DGLOCK",43,0) Q "RTN","DGLOCK",44,0) INE ;Ineligible "RTN","DGLOCK",45,0) D EK I $D(X),$S('$D(^DPT(DFN,.15)):1,$P(^(.15),U,2)']"":1,1:0) W !?4,$C(7),"Requirement for 'Ineligible patient' data not indicated...NO EDITING!" K X "RTN","DGLOCK",46,0) Q "RTN","DGLOCK",47,0) IR ;ION Rad "RTN","DGLOCK",48,0) D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,3)'="Y":1,1:0) W !?4,$C(7),"Exposure to Ionizing Radiation is not indicated...NO EDITING!" K X "RTN","DGLOCK",49,0) Q "RTN","DGLOCK",50,0) POW ;Prisoner of War "RTN","DGLOCK",51,0) D SV I $D(X),$S('$D(^DPT(DFN,.52)):1,$P(^(.52),U,5)'="Y":1,1:0) W !?5,$C(7),"Not identified as a former Prisoner of War...NO EDITING!" K X "RTN","DGLOCK",52,0) Q "RTN","DGLOCK",53,0) SER1 ;NTL Svc "RTN","DGLOCK",54,0) D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,19)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Other Periods of Service are not indicated...NO EDITING!" K X "RTN","DGLOCK",55,0) Q "RTN","DGLOCK",56,0) SER2 ;NNTL "RTN","DGLOCK",57,0) D SV I $D(X),$S('$D(^DPT(DFN,.32)):1,$P(^(.32),U,20)'="Y":1,X="N":0,1:0) W !?4,$C(7),"Third Period of Service is not indicated...NO EDITING!" K X "RTN","DGLOCK",58,0) Q "RTN","DGLOCK",59,0) TAD ;Temp Add Edit "RTN","DGLOCK",60,0) I $S('$D(^DPT(DFN,.121)):1,$P(^(.121),U,9)'="Y":1,1:0) W !?4,$C(7),"Requirement for Temporary Address data not indicated...NO EDITING!" K X "RTN","DGLOCK",61,0) Q "RTN","DGLOCK",62,0) TADD ;Temp Address Delete? "RTN","DGLOCK",63,0) Q:'$D(^DPT(DFN,.121)) I $P(^(.121),"^",9)="N"!($P(^(.121),"^",1,6)="^^^^^") Q "RTN","DGLOCK",64,0) ASK W !,"Do you want to delete all temporary address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove temporary address information, 'N'o to leave data in file" G ASK "RTN","DGLOCK",65,0) ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable "RTN","DGLOCK",66,0) I $G(DTOUT) S DGTMOT=1 "RTN","DGLOCK",67,0) Q:%'=1 D EN^DGCLEAR(DFN,"TEMP") Q "RTN","DGLOCK",68,0) VN ;Viet Svc "RTN","DGLOCK",69,0) D SV I $D(X),$S('$D(^DPT(DFN,.321)):1,$P(^(.321),U,1)'="Y":1,1:0) I "UN"'[$E(X) W !?4,$C(7),"Service in Republic of Vietnam not indicated...NO EDITING!" K X "RTN","DGLOCK",70,0) Q "RTN","DGLOCK",71,0) ; "RTN","DGLOCK",72,0) OEIF ;OIF/ OEF/ UNKNOWN OEF/OIF Svc "RTN","DGLOCK",73,0) D SV "RTN","DGLOCK",74,0) Q "RTN","DGLOCK",75,0) SVED ;Lebanon, Grenada, Panama, Persian Gulf & Yugoslavia svc edit "RTN","DGLOCK",76,0) ; (from and to dates) "RTN","DGLOCK",77,0) ;DGX = piece position of corresponding service indicated? field "RTN","DGLOCK",78,0) ; for multiple serv indicated dgx=sv1^sv2^... "RTN","DGLOCK",79,0) ;DGSV= service (sv1, sv2 from above) "RTN","DGLOCK",80,0) ;DGOK= 1=YES,at least one of the required sv indicated is yes,0=NO "RTN","DGLOCK",81,0) D SV I '$D(X) K DGX Q "RTN","DGLOCK",82,0) N DGSV,DGOK,DGPC,PC "RTN","DGLOCK",83,0) S DGOK=0 "RTN","DGLOCK",84,0) F PC=1:1 S DGSV=$P(DGX,U,PC) Q:DGSV']"" S:$P($G(^DPT(DFN,.322)),U,DGSV)="Y" DGOK=1 "RTN","DGLOCK",85,0) S PC=PC-1 "RTN","DGLOCK",86,0) I DGOK=0 D "RTN","DGLOCK",87,0) .I "UN"'[$E(X) D "RTN","DGLOCK",88,0) ..W !?4,$C(7),"Service in " "RTN","DGLOCK",89,0) ..F DGPC=1:1:PC D "RTN","DGLOCK",90,0) ...S DGSV=$P(DGX,U,DGPC) W $S(DGSV=1:"Lebanon",DGSV=4:"Grenada",DGSV=7:"Panama",DGSV=10:"Persian Gulf",DGSV=16:"Somalia",DGSV=19:"Yugoslavia",1:"") "RTN","DGLOCK",91,0) ...W:(DGPC$P(^DPT(DFN,.35),U) D "RTN","DGLOCK",104,0) . . D DOBDOD(DGFLD,2) "RTN","DGLOCK",105,0) Q "RTN","DGLOCK",106,0) POWV ;POW Status cannot be edited once it has been verified by the HEC "RTN","DGLOCK",107,0) ;DG*5.3*688 "RTN","DGLOCK",108,0) I $P($G(^DPT(DFN,.52)),U,9)'="" D EN^DDIOL("POW Status verified at the HEC...NO EDITING!!","","!?4") K X "RTN","DGLOCK",109,0) Q "RTN","DGLOCK",110,0) INEL ;check ineligible date - cannot be before DOB "RTN","DGLOCK",111,0) ;DG*5.3*754 "RTN","DGLOCK",112,0) N DGFLD "RTN","DGLOCK",113,0) I $G(X)<$P(^DPT(DFN,0),U,3) D "RTN","DGLOCK",114,0) . S DGFLD=$P(^DD(2,.152,0),U) "RTN","DGLOCK",115,0) . D DOBDOD(DGFLD,1) "RTN","DGLOCK",116,0) Q "RTN","DGLOCK",117,0) INCOM ;check date ruled incompetent (VA) - cannot be before DOB "RTN","DGLOCK",118,0) ;or after DOD - DG*5.3*754) "RTN","DGLOCK",119,0) N DGFLD "RTN","DGLOCK",120,0) S DGFLD=$P(^DD(2,.291,0),U) "RTN","DGLOCK",121,0) I $G(X)<$P(^DPT(DFN,0),U,3) D Q "RTN","DGLOCK",122,0) . D DOBDOD(DGFLD,1) "RTN","DGLOCK",123,0) I $P($G(^DPT(DFN,.35)),U)]"" D "RTN","DGLOCK",124,0) . I $G(X)>$P(^DPT(DFN,.35),U) D "RTN","DGLOCK",125,0) . . D DOBDOD(DGFLD,2) "RTN","DGLOCK",126,0) Q "RTN","DGLOCK",127,0) INCOM2 ;check date ruled incompetent (civil - cannot be before DOB "RTN","DGLOCK",128,0) ;or after DOD - DG*5.3*754) "RTN","DGLOCK",129,0) N DGFLD "RTN","DGLOCK",130,0) S DGFLD=$P(^DD(2,.292,0),U) "RTN","DGLOCK",131,0) I $G(X)<$P(^DPT(DFN,0),U,3) D Q "RTN","DGLOCK",132,0) . D DOBDOD(DGFLD,1) "RTN","DGLOCK",133,0) I $P($G(^DPT(DFN,.35)),U)]"" D "RTN","DGLOCK",134,0) . I $G(X)>$P(^DPT(DFN,.35),U) D "RTN","DGLOCK",135,0) . . D DOBDOD(DGFLD,2) "RTN","DGLOCK",136,0) Q "RTN","DGLOCK",137,0) DOBDOD(DGFLD,DGX) ;called from subroutines to check if "RTN","DGLOCK",138,0) ;date is before DOB or after DOD. The subroutines "RTN","DGLOCK",139,0) ;are called from the field input transforms. DG*5.3*754 "RTN","DGLOCK",140,0) I $G(DGFLD)']"" Q "RTN","DGLOCK",141,0) I "12"'[$G(DGX) Q "RTN","DGLOCK",142,0) D EN^DDIOL(DGFLD_" cannot be "_$S(DGX=1:"prior to",1:"after")_" Date of "_$S(DGX=1:"Birth.",1:"Death."),"","!?4") "RTN","DGLOCK",143,0) K X "RTN","DGLOCK",144,0) Q "RTN","DGLOCK",145,0) DEATH ;new date constraints added with ESR 3.1 - DG*5.3*754 "RTN","DGLOCK",146,0) Q:$G(X)'>0 "RTN","DGLOCK",147,0) N DGFLD "RTN","DGLOCK",148,0) S DGFLD=$P(^DD(2,.351,0),U) "RTN","DGLOCK",149,0) ;check for DOD before DOB "RTN","DGLOCK",150,0) I X<$P(^DPT(DFN,0),U,3) D DOBDOD(DGFLD,1) Q "RTN","DGLOCK",151,0) ;check for DOD before P&T Effective Date "RTN","DGLOCK",152,0) I X<$P($G(^DPT(DFN,.3)),U,13) D Q "RTN","DGLOCK",153,0) . D EN^DDIOL(DGFLD_" cannot be prior to the P&T Effective Date","","!?4") "RTN","DGLOCK",154,0) . K X "RTN","DGLOCK",155,0) ;check for DOD before Date Ruled Incompetent (VA) "RTN","DGLOCK",156,0) I X<$P($G(^DPT(DFN,.29)),U) D Q "RTN","DGLOCK",157,0) . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (VA)","","!?4") "RTN","DGLOCK",158,0) . K X "RTN","DGLOCK",159,0) ;check for DOD before Date Ruled Incompetent (Civil) "RTN","DGLOCK",160,0) I X<$P($G(^DPT(DFN,.29)),U,2) D Q "RTN","DGLOCK",161,0) . D EN^DDIOL(DGFLD_" cannot be prior to the Date Ruled Incompetent (Civil)","","!?4") "RTN","DGLOCK",162,0) . K X "RTN","DGLOCK",163,0) ;check for DOD before Enrollment Application Date "RTN","DGLOCK",164,0) ;I $P($G(^DPT(DFN,"ENR")),U)>0 D "RTN","DGLOCK",165,0) ;. N DGENR "RTN","DGLOCK",166,0) ;. S DGENR=$P(^DPT(DFN,"ENR"),U) "RTN","DGLOCK",167,0) ;. Q:$G(DGENR)']"" "RTN","DGLOCK",168,0) ;. Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN "RTN","DGLOCK",169,0) ;. I X<$P(^DGEN(27.11,DGENR,0),U) D "RTN","DGLOCK",170,0) ;. . D EN^DDIOL(DGFLD_" cannot be prior to the Enrollment Application Date","","!?4") "RTN","DGLOCK",171,0) ;. . K X "RTN","DGLOCK",172,0) Q "RTN","DGLOCK",173,0) BIRTH ;checks for DOB added with DG*5.3*754 "RTN","DGLOCK",174,0) I (($G(EASAPP)'="")&($G(DGADDF)=1)) Q ;Ignore New 1010EZ patients "RTN","DGLOCK",175,0) Q:$G(X)'>0 "RTN","DGLOCK",176,0) Q:'$D(DA) "RTN","DGLOCK",177,0) N DFN "RTN","DGLOCK",178,0) S DFN=DA "RTN","DGLOCK",179,0) N DGFLD "RTN","DGLOCK",180,0) S DGFLD=$P(^DD(2,.03,0),U) "RTN","DGLOCK",181,0) ;check for DOB after Ineligible Date "RTN","DGLOCK",182,0) I $P($G(^DPT(DFN,.15)),U,2)]"" D Q:'$G(X) "RTN","DGLOCK",183,0) . I X>$P(^DPT(DFN,.15),U,2) D "RTN","DGLOCK",184,0) . . D EN^DDIOL(DGFLD_" cannot be after the Ineligible Date","","!?4") K X "RTN","DGLOCK",185,0) ;check for DOB after Enrollment Application Date "RTN","DGLOCK",186,0) I $P($G(^DPT(DFN,"ENR")),U)>0 D "RTN","DGLOCK",187,0) . N DGENR "RTN","DGLOCK",188,0) . S DGENR=$P(^DPT(DFN,"ENR"),U) "RTN","DGLOCK",189,0) . Q:$G(DGENR)']"" "RTN","DGLOCK",190,0) . Q:$P($G(^DGEN(27.11,DGENR,0)),U,2)'=DFN "RTN","DGLOCK",191,0) . I X>$P(^DGEN(27.11,DGENR,0),U) D "RTN","DGLOCK",192,0) . . D EN^DDIOL(DGFLD_" cannot be after the Enrollment Application Date","","!?4") "RTN","DGLOCK",193,0) . . K X "RTN","DGLOCK",194,0) Q "RTN","DGLOCK",195,0) MSE ;Military Service Episode data cannot be edited once it has been "RTN","DGLOCK",196,0) ;verified by the HEC "RTN","DGLOCK",197,0) ;DG*5.3*797 "RTN","DGLOCK",198,0) I "NU"'[$E(X) D VET Q:'$D(X) "RTN","DGLOCK",199,0) I $P($G(^DPT(DFN,.3216,DA,0)),U,7)=1 D EN^DDIOL("MSE data verified at the HEC...NO EDITING!!","","!?4") K X "RTN","DGLOCK",200,0) Q "RTN","DGLOCK3") 0^16^B11146338^B10959586 "RTN","DGLOCK3",1,0) DGLOCK3 ;ALB/BOK,BAJ,JAM - PATIENT FILE MUMPS TRIGGER/DATA EDIT CHECKS ; 01/23/2006 "RTN","DGLOCK3",2,0) ;;5.3;Registration;**489,527,688,1014,1040**;Aug 13,1993;Build 15 "RTN","DGLOCK3",3,0) ; DG*5.3*688 BAJ 01/23/2006 Changed to support foreign confidential addresses "RTN","DGLOCK3",4,0) KILL S DGX=X I $D(^DPT(DFN,.32)) F DGKZ=0:0 S DGKZ=$O(DGBZ(DGKZ)) Q:'DGKZ S X=$P(^DPT(DFN,.32),"^",DGKZ),$P(^(.32),"^",DGKZ)="" I X]"" S DGIZ=$S(DGKZ=20:.32945,1:(DGKZ/10000+.3281)) I $D(^DD(2,DGIZ,1)) D KILL1 "RTN","DGLOCK3",5,0) S X=DGX "RTN","DGLOCK3",6,0) Q "RTN","DGLOCK3",7,0) KILL1 F DGJZ=0:0 S DGJZ=$O(^DD(2,DGIZ,1,DGJZ)) Q:'DGJZ X ^(DGJZ,2) "RTN","DGLOCK3",8,0) Q "RTN","DGLOCK3",9,0) S1 K DGBZ F DGKZ=9:1:13,20 S DGBZ(DGKZ)="" "RTN","DGLOCK3",10,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",11,0) Q "RTN","DGLOCK3",12,0) S2 K DGBZ F DGKZ=14:1:18 S DGBZ(DGKZ)="" "RTN","DGLOCK3",13,0) D KILL K DGBZ,DGIZ,DGJZ,DGKZ "RTN","DGLOCK3",14,0) Q "RTN","DGLOCK3",15,0) CAD ;Confidential Address Edit "RTN","DGLOCK3",16,0) I $S('$D(^DPT(DFN,.141)):1,$P(^(.141),U,9)'="Y":1,1:0) D "RTN","DGLOCK3",17,0) .D EN^DDIOL("Requirement for Confidential Address data not indicated...NO EDITING!","","$C(7),!?4") K X "RTN","DGLOCK3",18,0) Q "RTN","DGLOCK3",19,0) CADD ;Confidential Address Delete "RTN","DGLOCK3",20,0) ;Called from input transform on Confidential Address fields "RTN","DGLOCK3",21,0) Q:'$D(^DPT(DFN,.141)) I $P(^(.141),"^",9)="N"!($P(^(.141),"^",1,6)="^^^^^") D Q "RTN","DGLOCK3",22,0) .N DGFDA,DGERR "RTN","DGLOCK3",23,0) .D CADM "RTN","DGLOCK3",24,0) .I $D(DGFDA) D "RTN","DGLOCK3",25,0) ..N DGX "RTN","DGLOCK3",26,0) ..S DGX=X "RTN","DGLOCK3",27,0) ..D FILE^DIE("","DGFDA","DGERR") "RTN","DGLOCK3",28,0) ..S X=DGX "RTN","DGLOCK3",29,0) ; "RTN","DGLOCK3",30,0) ASK W !,"Do you want to delete all confidential address data" S %=2 D YN^DICN I %Y["?" W !,"Answer 'Y'es to remove confidential address information, 'N'o to leave data in file" G ASK "RTN","DGLOCK3",31,0) ASK1 ; "RTN","DGLOCK3",32,0) ; DG*5.3*1040 - Set DGTMOT on timeout. Calling routine checks for this variable to process timeout and cleanup this variable "RTN","DGLOCK3",33,0) I $G(DTOUT) S DGTMOT=1 "RTN","DGLOCK3",34,0) Q:%'=1 "RTN","DGLOCK3",35,0) D EN^DGCLEAR(DFN,"CONF") "RTN","DGLOCK3",36,0) D CADM "RTN","DGLOCK3",37,0) N DGX "RTN","DGLOCK3",38,0) S DGX=X "RTN","DGLOCK3",39,0) D FILE^DIE("","DGFDA","DGERR") "RTN","DGLOCK3",40,0) S X=DGX "RTN","DGLOCK3",41,0) Q "RTN","DGLOCK3",42,0) CADM ;Delete data from Confidential Address Categories "RTN","DGLOCK3",43,0) I $D(^DPT(DFN,.14)) D "RTN","DGLOCK3",44,0) .N DGIEN "RTN","DGLOCK3",45,0) .S DGIEN=0 "RTN","DGLOCK3",46,0) .F S DGIEN=$O(^DPT(DFN,.14,DGIEN)) Q:'DGIEN D "RTN","DGLOCK3",47,0) ..S DGFDA(2.141,DGIEN_","_DFN_",",.01)="" "RTN","DGLOCK3",48,0) Q "RTN","DGLOCK3",49,0) CADD1 ;Confidential Address Delete "RTN","DGLOCK3",50,0) ;Called from Confidential Address "DEL" nodes "RTN","DGLOCK3",51,0) I $D(^DPT(DFN,.141)),$P(^(.141),U,9)="Y" D "RTN","DGLOCK3",52,0) .D EN^DDIOL("Answer NO to the 'CONFIDENTIAL ADDRESS ACTIVE' prompt to delete.","","$C(7),!?4") K X "RTN","DGLOCK3",53,0) Q "RTN","DGLOCK3",54,0) ; "RTN","DGLOCK3",55,0) COV(DGELG) ; Rule for deleting COLLATERAL OF VET eligibility code DG*5.3*1014;jam; "RTN","DGLOCK3",56,0) ; Cannot delete COV if there is an active CCP assigned to the Patient "RTN","DGLOCK3",57,0) ; Invoked by: "RTN","DGLOCK3",58,0) ; DELETE TEST - .361 (PRIMARY ELIGIBILITY) "RTN","DGLOCK3",59,0) ; - .01 (ELIGIBILITY CODE) of the PATIENT ELIGIBILITIES subfile (.0361) "RTN","DGLOCK3",60,0) ; Input: DGELG - Eligibility code being deleted (Optional - defaults to Primary Elig Code, field .361) "RTN","DGLOCK3",61,0) ; "RTN","DGLOCK3",62,0) I $G(DGELG)="" S DGELG=$$GET1^DIQ(2,DFN_",",.361,"I") "RTN","DGLOCK3",63,0) ; OK if not deleting COLLATERAL OF VET "RTN","DGLOCK3",64,0) I DGELG'=$$FIND1^DIC(8,"","B","COLLATERAL OF VET") Q "RTN","DGLOCK3",65,0) N DGFLG,DGCCP "RTN","DGLOCK3",66,0) S (DGFLG,DGCCP)=0 "RTN","DGLOCK3",67,0) F S DGCCP=$O(^DPT(DFN,5,DGCCP)) Q:'DGCCP I $G(^DPT(DFN,5,DGCCP,0))'="" D Q:DGFLG "RTN","DGLOCK3",68,0) . ; If CCP without an End Date - cannot delete COV "RTN","DGLOCK3",69,0) . I '$P(^DPT(DFN,5,DGCCP,0),"^",4) S DGFLG=1 "RTN","DGLOCK3",70,0) I DGFLG D EN^DDIOL("This eligibility cannot be removed while there are active CCP(s) assigned to the Patient. Please advance to Data Group [2] on Screen <11.5> to remove the active CCP(s).") K X "RTN","DGLOCK3",71,0) Q "RTN","DGREG") 0^2^B160323026^B156355963 "RTN","DGREG",1,0) DGREG ;ALB/JDS,MRL/PJR/PHH,ARF-REGISTER PATIENT ; 3/28/14 12:38pm "RTN","DGREG",2,0) ;;5.3;Registration;**1,32,108,147,149,182,245,250,513,425,533,574,563,624,658,864,886,915,926,1024,993,1040**;Aug 13, 1993;Build 15 "RTN","DGREG",3,0) ; "RTN","DGREG",4,0) START ; "RTN","DGREG",5,0) EN D LO^DGUTL S DGCLPR="" "RTN","DGREG",6,0) N DGDIV "RTN","DGREG",7,0) S DGDIV=$$PRIM^VASITE "RTN","DGREG",8,0) S:DGDIV %ZIS("B")=$P($G(^DG(40.8,+DGDIV,"DEV")),U,1) "RTN","DGREG",9,0) I $P(^DG(43,1,0),U,39) S %ZIS="NQ",%ZIS("A")="Select 1010 printer: " D ^%ZIS Q:POP S (DGIO(10),DGIO("PRF"),DGIO("RT"),DGIO("HS"))=ION,DGASKDEV="" I $E(IOST,1,2)'["P-" W !,$C(7),"Not a printer" G DGREG "RTN","DGREG",10,0) K %ZIS("B") "RTN","DGREG",11,0) I '$D(DGIO),$P(^DG(43,1,0),U,30) S %ZIS="N",IOP="HOME" D ^%ZIS I $D(IOS),IOS,$D(^%ZIS(1,+IOS,99)),$D(^%ZIS(1,+^(99),0)) S Y=$P(^(0),U,1) W !,"Using closest printer ",Y,! F I=10,"PRF","RT","HS" S DGIO(I)=Y "RTN","DGREG",12,0) A D ENDREG($G(DFN)) "RTN","DGREG",13,0) ; DG*5.3*1040 - NEW variable DGTMOT and initialize to 0 to track timeout in address and DGADDRE to track the return value of $$ADD^DGADDUTL "RTN","DGREG",14,0) N DGADDRE,DGTMOT S DGTMOT=0,DGADDRE="" "RTN","DGREG",15,0) N DGNEWP ;**1024 USING DGNEWP INSTEAD OF JUST DGNEWP TO AVOID Y BEING RESET ON US "RTN","DGREG",16,0) W !! S DIC=2,DIC(0)="ALEQM",DLAYGO=2 K DIC("S"),DIC("B") D ^DIC K DLAYGO G Q1:Y<0 S (DFN,DA)=+Y,DGNEW=$G(DGNEWP) N Y D PAUSE^DG10 D BEGINREG(DFN) I DGNEW D NEW^DGRP "RTN","DGREG",17,0) ; "RTN","DGREG",18,0) ;; ask to continue if patient died - DG*5.3*563 - pjr 10/12/04 "RTN","DGREG",19,0) S DOD="" I $G(DFN) S DOD=$P($G(^DPT(DFN,.35)),"^",1) "RTN","DGREG",20,0) I DOD S Y=DOD,DGPME=0 D DIED^DGPMV I DGPME K DFN,DGRPOUT G A "RTN","DGREG",21,0) ; "RTN","DGREG",22,0) D CIRN "RTN","DGREG",23,0) ; "RTN","DGREG",24,0) I +$G(DGNEW) D "RTN","DGREG",25,0) . ; query CMOR for Patient Record Flag Assignments if NEW patient and "RTN","DGREG",26,0) . ; display results. "RTN","DGREG",27,0) . I $$PRFQRY^DGPFAPI(DFN) D DISPPRF^DGPFAPI(DFN) "RTN","DGREG",28,0) . I $$EN^DGPFMPI(DFN) "RTN","DGREG",29,0) ; "RTN","DGREG",30,0) D ROMQRY "RTN","DGREG",31,0) ; "RTN","DGREG",32,0) ; DG*5.3*993 The DO YOU WISH TO ENROLL, ENROLLMENT DATE, and DO YOU WANT AN APPT questions "RTN","DGREG",33,0) ; were moved here from the end of patient registration. Also, if the patient does not wish to enroll "RTN","DGREG",34,0) ; a REGISTRATION REASON question will be asked "RTN","DGREG",35,0) N DGBACK,DGENRDT,DGENRIEN,DGENRRSN,DGENRYN,DGERR,DGEXIT,DGFDA,DGFDD,DGIEN,DGNOW,DGOUT,DGSTA,DGVET,DGX,DGY,DIE,DIR,DR "RTN","DGREG",36,0) ; Do you wish to enroll? "RTN","DGREG",37,0) S DGBACK=0,DGSTA="",DGIEN=$$FINDCUR^DGENA(DFN) I DGIEN S DGSTA=$$GET1^DIQ(27.11,DGIEN_",",.04) "RTN","DGREG",38,0) K DGOUT D GETS^DIQ(2,DFN_",",".3216*","I","DGOUT") "RTN","DGREG",39,0) S DGFDD=0,DGX="" F S DGX=$O(DGOUT(2.3216,DGX),-1) Q:DGX="" S DGFDD=+$G(DGOUT(2.3216,DGX,.08)) Q:DGFDD ;DGFDD=Future Discharge Date "RTN","DGREG",40,0) ENRYN S DGBACK=0,DGENRYN="",DGVET=$$VET^DGENPTA(DFN) S:'DGVET DGENRYN=0 "RTN","DGREG",41,0) N STATUS,DGPREXST,DGPTAPPLD,DGCURR S DGPTAPPLD="",DGPREXST="",DGPREXST=$$PREEXIST(DFN),STATUS="",STATUS=$$STATUS^DGENA($G(DFN)) I STATUS=25 S DGENRYN=0,DGPREXST=0 "RTN","DGREG",42,0) S DGCURR="",DGCURR=$$FINDCUR^DGENA(DFN) I DGCURR S DGPTAPPLD=$$GET1^DIQ(27.11,DGCURR_",",.14,"I") "RTN","DGREG",43,0) I ($G(DGPTAPPLD)=0) I DGPTAPPLD=1 S DGENRYN=1 "RTN","DGREG",44,0) I $$GET1^DIQ(2,DFN_",",.351)="",'DGFDD,'DGPREXST,DGVET,$G(DGPTAPPLD)'=1 F D Q:DGENRYN'=""!(DGBACK) "RTN","DGREG",45,0) . K DIR,DTOUT I ($G(DGPTAPPLD)=0) S DIR("B")="NO" "RTN","DGREG",46,0) . S DIR(0)="Y",DIR("A")="DO YOU WISH TO ENROLL" "RTN","DGREG",47,0) . S DIR("?")="Select Y or YES if the patient wants to apply for enrollment for VHA Healthcare benefits. Select N or NO if the patient only wants to register without applying for enrollment." "RTN","DGREG",48,0) . S DIR("??")="^D HELPENR^DGREG" "RTN","DGREG",49,0) . D ^DIR "RTN","DGREG",50,0) . I ($G(DGPTAPPLD)="")&((X["Y")!(X["y")) S DGENRYN=1 Q "RTN","DGREG",51,0) . I ($G(DGPTAPPLD)="")&(X["N")!(X["n") S DGENRYN=0 Q "RTN","DGREG",52,0) . I ($G(DGPTAPPLD)=0)&(X["Y")!(X["y") W !!?5,"This is an existing patient. To complete the enrollment" W !?5,"application process, please use the Enrollment System." "RTN","DGREG",53,0) . I ($G(DGPTAPPLD)=0)&(X["Y")!(X["y") W !!!?5,"Press to Continue or '^' to exit:" R X:DTIME "RTN","DGREG",54,0) . S:$D(DTOUT)!(X=U) DGBACK=1 "RTN","DGREG",55,0) G:DGBACK A "RTN","DGREG",56,0) S:DGFDD DGENRYN=1 "RTN","DGREG",57,0) S DGENRRSN="",DGNOW=$$NOW^XLFDT() "RTN","DGREG",58,0) I (DGENRYN=0)&('DGPREXST) D G:DGENRRSN="^" ENRYN "RTN","DGREG",59,0) . ;REGISTRATION ONLY REASON "RTN","DGREG",60,0) . S DGY="",DGX=$$FINDCUR^DGENA(DFN) S:DGX?1.N DGY=$$GET1^DIQ(27.11,DGX_",",.15) "RTN","DGREG",61,0) . I (DGY="")&(STATUS="") D "RTN","DGREG",62,0) . . W !,"SELF-REPORTED REGISTRATION ONLY REASON" "RTN","DGREG",63,0) . . I D Q:DGENRRSN'="" "RTN","DGREG",64,0) . . . K DIR S DIR(0)=$$SETSET($S($P(XQY0,U,2)="Collateral Patient Register":2,1:1)),DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON" D ^DIR "RTN","DGREG",65,0) . . . S:$D(DTOUT)!($D(DUOUT)) DGENRRSN="^" S:$D(Y(0)) DGENRRSN=$$GETSET(Y(0)) Q:Y="^" "RTN","DGREG",66,0) . . . S DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration "RTN","DGREG",67,0) ENRDATE ; "RTN","DGREG",68,0) N DGBACK,DGENRDTT,ANS "RTN","DGREG",69,0) S DGBACK=0 "RTN","DGREG",70,0) I (DGENRYN=1) S DGEXIT=0 D G:DGEXIT ENRYN "RTN","DGREG",71,0) . ;ENROLLMENT APPLICATION DATE "RTN","DGREG",72,0) . K Y D PROMPT^DGENU(27.11,.01,"NOW",,1,1) S:$E(Y)="^" DGEXIT=1 Q:DGEXIT D ;DG*5.3*993 "RTN","DGREG",73,0) . . S DGENRDTT=Y S:Y?1.N.E DGENRDT=Y\1 S:Y="" DGENRDT=DGNOW\1,DGENRDTT=DGNOW "RTN","DGREG",74,0) . ; DO YOU WANT AN APPT. WITH A VA DOCTOR/PROVIDER AS SOON AS AVAILABLE? "RTN","DGREG",75,0) . ; If YES, update fields #2,#1010.159 and #2,#1010.1511 (NOTE: This code came from DGEN) "RTN","DGREG",76,0) . D:$P($G(^DPT(DFN,1010.15)),"^",9)="" "RTN","DGREG",77,0) . . N DGSXS,DGAPPTAN,DGDFLT S DGSXS="",DGDFLT="" "RTN","DGREG",78,0) . . S:DGDFLT="" DGDFLT=1 "RTN","DGREG",79,0) . . S DGSXS=$$PROMPT^DGENU(2,1010.159,1,.DGAPPTAN,"",1) S:'DGSXS DGBACK=1 "RTN","DGREG",80,0) . . I DGSXS D "RTN","DGREG",81,0) . . . N DA,DR,DIE "RTN","DGREG",82,0) . . . S DA=DFN "RTN","DGREG",83,0) . . . S DIE="^DPT(" "RTN","DGREG",84,0) . . . S DR="1010.159///^S X=DGAPPTAN" "RTN","DGREG",85,0) . . . D ^DIE "RTN","DGREG",86,0) . . . K DA,DR,DIE "RTN","DGREG",87,0) . . . ;*Set Appointment Request Date to current date "RTN","DGREG",88,0) . . . I DGAPPTAN D "RTN","DGREG",89,0) . . . . N DA,DR,DIE "RTN","DGREG",90,0) . . . . S DIE="^DPT(" "RTN","DGREG",91,0) . . . . S DA=DFN "RTN","DGREG",92,0) . . . . S DGENRDTT=$$HLDATE^HLFNC(DGENRDTT,"DT") "RTN","DGREG",93,0) . . . . S DR="1010.1511///^S X=DGENRDTT" "RTN","DGREG",94,0) . . . . D ^DIE "RTN","DGREG",95,0) . . . . K DA,DR,DIE "RTN","DGREG",96,0) . . .;*If patient answered NO to "Do you want an appt" question "RTN","DGREG",97,0) . . . I DGAPPTAN=0 D "RTN","DGREG",98,0) . . . . N DA,DR,DIE "RTN","DGREG",99,0) . . . . S DIE="^DPT(" "RTN","DGREG",100,0) . . . . S DA=DFN "RTN","DGREG",101,0) . . . . S DR="1010.1511///^S X=DT" "RTN","DGREG",102,0) . . . . D ^DIE "RTN","DGREG",103,0) . . . . K DA,DR,DIE "RTN","DGREG",104,0) . S DGY="",DGX=$$FINDCUR^DGENA(DFN) S:DGX?1.N DGY=$$GET1^DIQ(27.11,DGX_",",.16) D:DGY="" "RTN","DGREG",105,0) . . S DGENRRSN="",DGENRODT=DGNOW,DGENSRCE=1 ;These fields will be filed in the PATIENT ENROLLMENT file at the end of registration "RTN","DGREG",106,0) ; "RTN","DGREG",107,0) G:DGBACK ENRYN "RTN","DGREG",108,0) ; END OF DG*5.3*993 mods "RTN","DGREG",109,0) S (DGFC,CURR)=0 "RTN","DGREG",110,0) D:'$G(DGNEW) WARN S DA=DFN,DGFC="^1",VET=$S($D(^DPT(DFN,"VET")):^("VET")'="Y",1:0) "RTN","DGREG",111,0) S %ZIS="N",IOP="HOME" D ^%ZIS S DGELVER=0 D EN^DGRPD I $D(DGRPOUT) D ENDREG($G(DFN)) D HL7A08^VAFCDD01 K DFN,DGRPOUT G A "RTN","DGREG",112,0) D HINQ^DG10 "RTN","DGREG",113,0) I $D(^DIC(195.4,1,"UP")) I ^("UP") D ADM^RTQ3 "RTN","DGREG",114,0) D REG^IVMCQ($G(DFN)) ; send financial query "RTN","DGREG",115,0) G A1 "RTN","DGREG",116,0) ; "RTN","DGREG",117,0) ; "RTN","DGREG",118,0) PREEXIST(DFN) ;DG*5.3*993 - Did this patient exist before the installation of DG*5.3*993 "RTN","DGREG",119,0) N DGX,DGINST,DGINSTAT,DGINSTID,DGICN,DGEXIST,DGARR,DGREC,DGESKNOWN,I "RTN","DGREG",120,0) S (DGEXIST,DGICN)="" "RTN","DGREG",121,0) S DGICN=+($$GETICN^MPIF001(DFN)) "RTN","DGREG",122,0) I DGICN=-1 Q 0 "RTN","DGREG",123,0) K DGARR I DGICN'=-1 S DGEXIST=$$QUERYTF^VAFCTFU1(DGICN,"DGARR","") ; check Treating Facility returns 1^text if not found "RTN","DGREG",124,0) I $P(DGEXIST,"^",1)=1 Q 0 "RTN","DGREG",125,0) S DGX=0,DGESKNOWN=0,I=0,DGREC="",DGINSTID="" F I=1:1 Q:'$D(DGARR(I)) S DGREC=DGARR(I) D Q:DGESKNOWN=1 "RTN","DGREG",126,0) . S DGINSTAT="",DGINST=$P(DGREC,"^",1) "RTN","DGREG",127,0) . S DGINSTID=$P($G(^DIC(4,DGINST,9999,1,0)),"^",2) I DGINSTID="200ESR" S DGINSTAT=$$GET1^DIQ(4,DGINST_",",99) "RTN","DGREG",128,0) . I (DGINSTID="200ESR")&(DGINSTAT="200ESR") S DGESKNOWN=1 "RTN","DGREG",129,0) I (DGESKNOWN=1) S DGX=1 ;if exist to ES and applied="" it preexist "RTN","DGREG",130,0) I (DGESKNOWN=0)&(DGEXIST'=0) S DGX=0 ;not known to ES and not in treating facility (new record) "RTN","DGREG",131,0) I (DGESKNOWN=0)&(DGEXIST="") S DGX=0 ;new record "RTN","DGREG",132,0) Q DGX "RTN","DGREG",133,0) ; "RTN","DGREG",134,0) HELPENR ;DG*5.3*993 - Help for ?? on the DO YOU WISH TO ENROLL? question "RTN","DGREG",135,0) W !,"Select Y or YES if the patient wants to apply for enrollment for VHA" "RTN","DGREG",136,0) W !,"Healthcare benefits. Select N or NO if the patient only wants to" "RTN","DGREG",137,0) W !,"register without applying for enrollment." "RTN","DGREG",138,0) Q "RTN","DGREG",139,0) ; "RTN","DGREG",140,0) SETSET(TYPE) ;DG*5.3*993 - Help display for field #27.11,#.01 single and double ? "RTN","DGREG",141,0) ;Input: TYPE 1=REGISTER A PATIENT 2=COLLATERAL PATIENT "RTN","DGREG",142,0) ; "RTN","DGREG",143,0) N DGL,DGN,DGOUT,DGRS,DGX "RTN","DGREG",144,0) S DGOUT="S^",DGL=0 "RTN","DGREG",145,0) S DGRS="" F S DGRS=$O(^DG(408.43,"B",DGRS)) Q:DGRS="" S DGN=$O(^DG(408.43,"B",DGRS,"")) D "RTN","DGREG",146,0) . I DGN S DGX=$$GET1^DIQ(408.43,DGN_",",.02,"I") I DGX=1!(DGX=2) D "RTN","DGREG",147,0) .. I TYPE=1&(DGX=1!(DGX=2)) S DGL=DGL+1,DGOUT=DGOUT_DGL_":"_DGRS_";" Q "RTN","DGREG",148,0) .. I TYPE=2,DGX=2 S DGL=DGL+1,DGOUT=DGOUT_DGL_":"_DGRS_";" "RTN","DGREG",149,0) Q DGOUT "RTN","DGREG",150,0) ; "RTN","DGREG",151,0) GETSET(REASON) ; "RTN","DGREG",152,0) ;Input REASON is the name of the REGISTRATION ONLY REASON "RTN","DGREG",153,0) ;Output The IEN of the REGISTRATION ONLY REASON "RTN","DGREG",154,0) Q $O(^DG(408.43,"B",REASON,"")) "RTN","DGREG",155,0) ; "RTN","DGREG",156,0) PAUSE ; "RTN","DGREG",157,0) N DIR "RTN","DGREG",158,0) S DIR(0)="E" D ^DIR "RTN","DGREG",159,0) Q "RTN","DGREG",160,0) ; "RTN","DGREG",161,0) RT I $D(^DIC(195.4,1,"UP")) I ^("UP") S $P(DGFC,U,1)=DIV D ADM^RTQ3 "RTN","DGREG",162,0) Q "RTN","DGREG",163,0) ; "RTN","DGREG",164,0) ; DG*5.3*1040 - If variable DGADDRE=-1, branch to Q due to timeout; if DGRPOUT=1, branch to Q as well "RTN","DGREG",165,0) A1 W !,"Do you want to ",$S(DGNEW:"enter",1:"edit")," Patient Data" S %=1 D YN^DICN D G:$G(DGADDRE)=-1 Q G H:'%,CK:%'=1 S DGRPV=0 D EN1^DGRP G:+$G(DGRPOUT) Q G Q:'$D(DA) "RTN","DGREG",166,0) .I +$G(DGNEW) Q "RTN","DGREG",167,0) .S DGADDRE=$$ADD^DGADDUTL($G(DFN)) ; DG*5.3*1040 - Store the return value in DGADDRE "RTN","DGREG",168,0) G CH "RTN","DGREG",169,0) PR W !!,"Is the patient currently being followed in a clinic for the same condition" S %=0 D YN^DICN G Q:%=-1 "RTN","DGREG",170,0) I '% W !?4,$C(7),"Enter 'Y' if the patient is being followed in clinic for condition for which",!?6,"registered, 'N' if not." G PR "RTN","DGREG",171,0) S CURR=% G SEEN "RTN","DGREG",172,0) ; "RTN","DGREG",173,0) CK S DGEDCN=1 D ^DGRPC "RTN","DGREG",174,0) CH S X=$S('$D(^DPT(DFN,.36)):1,$P(^(.36),"^",1)']"":1,1:0),X1=$S('$D(^DPT(DFN,.32)):1,$P(^(.32),"^",3)']"":1,1:0) I 'X,'X1 G CH1 "RTN","DGREG",175,0) CH1 S DA=DFN G PR:'$D(^DPT("ADA",1,DA)) W !!,"There is still an open disposition--register aborted.",$C(7),$C(7) G Q "RTN","DGREG",176,0) SEEN W !!,"Is the patient to be examined in the medical center today" S %=1 D YN^DICN S SEEN=% G:%<0 Q I %'>0 W !!,"Enter 'Y' if the patient is to be examined today, 'N' if not.",$C(7) G SEEN "RTN","DGREG",177,0) ABIL D ^DGREGG "RTN","DGREG",178,0) ENR ; next line appears to be dead code. left commented just to test. mli 4/28/94 "RTN","DGREG",179,0) ;S DE=0 F I=0:0 S I=$O(^DPT(DA,"DE",I)) Q:'I I $P(^(I,0),"^",3)'?7N Q D PR:'DE S L=+$P($S($D(^SC(L,0)):^(0),1:""),"^",1) "RTN","DGREG",180,0) REG S (DIE,DIC)="^DPT("_DFN_",""DIS"",",%DT="PTEX",%DT("A")="Registration login date/time: NOW// " "RTN","DGREG",181,0) W !,%DT("A") R ANS:DTIME S:'$T ANS="^" S:ANS="" ANS="N" S X=ANS G Q:ANS="^" S DA(1)=DFN D CHK^DIE(2.101,.01,"E",X,.RESULT) G REG:RESULT="^"!('$D(RESULT)),PR3:'(RESULT#1) S Y=RESULT "RTN","DGREG",182,0) I (RESULT'="^") W " ("_RESULT(0)_")" "RTN","DGREG",183,0) S DINUM=9999999-RESULT "RTN","DGREG",184,0) S (DFN1,Y1)=DINUM,APD=Y I $D(^DPT(DFN,"DIS",Y1)) W !!,"You must enter a date that does not exist.",$C(7),$C(7) G REG "RTN","DGREG",185,0) ;patch 886 changed to incremental lock and dilocktm "RTN","DGREG",186,0) G:$D(^DPT("ADA",1,DA)) CH1 L +@(DIE_DINUM_")"):$G(DILOCKTM,3) G:'$T MSG S:'($D(^DPT(DA(1),"DIS",0))#2) ^(0)="^2.101D^^" S DIC(0)="L",X=+Y D ^DIC "RTN","DGREG",187,0) ; "RTN","DGREG",188,0) ;SAVE OFF DATE/TIME OF REGISTRATION FOR HL7 V2.3 MESSAGING, IN VAFCDDT "RTN","DGREG",189,0) S VAFCDDT=X "RTN","DGREG",190,0) ; DG*5.3*993 Decoupling project code for register only "RTN","DGREG",191,0) N DGSTUS,DGCHK "RTN","DGREG",192,0) S DGCHK=0 "RTN","DGREG",193,0) S DGSTUS=$$STATUS^DGENA($G(DFN)) I DGSTUS=25 S DGCHK=1,DGENRYN=0 ; If DGSTUS=25 patient is Register Only ;27.11 TEST "RTN","DGREG",194,0) S DGENRYN=$G(DGENRYN) I DGENRYN=0 S DGCHK=1 ;DG*5.3*993 If DGENRYN=1 patient said YES to enroll "RTN","DGREG",195,0) I DGCHK=1 D "RTN","DGREG",196,0) . S DA=DFN1,DIE("NO^")="" "RTN","DGREG",197,0) . S DA(1)=DFN,DP=2.101 "RTN","DGREG",198,0) . S DR="1///"_$S(SEEN=2:2,SEEN=1:0,1:0)_";Q;2//OUTPATIENT MEDICAL"_";7///"_$S(SEEN=2:0,SEEN=1:1,1:0)_";2.1//ALL OTHER;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4///"_DUZ "RTN","DGREG",199,0) I DGCHK=0 D "RTN","DGREG",200,0) . S DA=DFN1,DIE("NO^")="" "RTN","DGREG",201,0) . S DA(1)=DFN,DP=2.101 "RTN","DGREG",202,0) . S DR="1///"_$S(SEEN=2:2,CURR=1:1,1:0)_";Q;2"_$S(CURR=1:"///3",1:"")_";2.1;3//"_$S($P(^DG(43,1,"GL"),"^",2):"",1:"/")_$S($D(^DG(40.8,+$P(^DG(43,1,"GL"),"^",3),0)):$P(^(0),"^",1),1:"")_";4////"_DUZ "RTN","DGREG",203,0) ;patch 886 changed lock to use dilocktm "RTN","DGREG",204,0) D EL K DIC("A") N DGNDLOCK S DGNDLOCK=DIE_DFN1_")" L +@DGNDLOCK:$G(DILOCKTM,3) G:'$T MSG D ^DIE L -@DGNDLOCK "RTN","DGREG",205,0) I $D(DTOUT) D G Q "RTN","DGREG",206,0) .K DTOUT "RTN","DGREG",207,0) .N DA,DIK "RTN","DGREG",208,0) .S DA(1)=DFN,DA=DFN1,DIK="^DPT("_DFN_",""DIS""," "RTN","DGREG",209,0) .D ^DIK "RTN","DGREG",210,0) .W !!?5,"User Time-out. Required registration data could be missing." "RTN","DGREG",211,0) .W !,?5,"This registration has been deleted." "RTN","DGREG",212,0) ; check whether facility applying to (division) is inactive "RTN","DGREG",213,0) I '$$DIVCHK^DGREGFAC(DFN,DFN1) G CONT "RTN","DGREG",214,0) ASKDIV W !!?5,"The facility chosen either has no pointer to an Institution" "RTN","DGREG",215,0) W !?5,"file record or the Institution file record is inactive." "RTN","DGREG",216,0) W !?5,"Please choose another division." "RTN","DGREG",217,0) S DA=DFN1,DIE("NO^")="",DA(1)=DFN,DP=2.101,DR="3" D ^DIE "RTN","DGREG",218,0) I $$DIVCHK^DGREGFAC(DFN,DFN1) G ASKDIV "RTN","DGREG",219,0) CONT ; continue "RTN","DGREG",220,0) S DGXXXD=1 D EL^DGREGE I $P(^DPT(DFN,"DIS",DFN1,0),"^",3)=4 S DA=DFN,DIE="^DPT(",DR=".368;.369" D ^DIE S DIE="^DPT("_DFN_",""DIS"",",DA(1)=DFN,DA=DFN1 "RTN","DGREG",221,0) S DA=DFN,DR="[DGREG]",DIE="^DPT(" D ^DIE K DIE("NO^") "RTN","DGREG",222,0) I $D(^DPT(DFN,"DIS",DFN1,2)),$P(^(2),"^",1)="Y" S DIE="^DPT(",DR="[DG EMPLOYER]",DA=DFN D ^DIE "RTN","DGREG",223,0) G ^DGREG0 "RTN","DGREG",224,0) PR2 W !!,"You can only enter new registrations through this option.",$C(7),$C(7) G REG "RTN","DGREG",225,0) PR3 W !!,"Time is required to register the patient.",!!,$C(7),$C(7) G REG "RTN","DGREG",226,0) H W !?5,"Enter 'YES' to enter/edit registration data or 'NO' to continue." G A1 "RTN","DGREG",227,0) ; DG*5.3*1040 - Cleanup variable DGTMOT "RTN","DGREG",228,0) Q K DG,DQ,DGTMOT G Q1^DGREG0 "RTN","DGREG",229,0) Q1 K DGIO,DGASKDEV,DGFC,DGCLRP,CURR,DGELVER,DGNEW Q "RTN","DGREG",230,0) EL S DR=DR_";13//" I $D(^DPT(DFN,.36)),$D(^DIC(8,+^(.36),0)) S DR=DR_$P(^(0),"^",1) Q "RTN","DGREG",231,0) S DR=DR_"HUMANITARIAN EMERGENCY" Q "RTN","DGREG",232,0) FEE S DGRPFEE=1 D DGREG K DGRPFEE G Q1 "RTN","DGREG",233,0) ; "RTN","DGREG",234,0) WARN I $S('$D(^DPT(DFN,.1)):0,$P(^(.1),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY AN INPATIENT***",! H 2 "RTN","DGREG",235,0) I $S('$D(^DPT(DFN,.107)):0,$P(^(.107),"^",1)']"":0,1:1) W !,$C(7),"***PATIENT IS CURRENTLY A LODGER***",! H 2 "RTN","DGREG",236,0) Q "RTN","DGREG",237,0) MSG W !,"Another user is editing, try later ..." G Q "RTN","DGREG",238,0) ; "RTN","DGREG",239,0) BEGINREG(DFN) ; "RTN","DGREG",240,0) N DGQRY "RTN","DGREG",241,0) ;Description: This is called at the beginning of the registration process. "RTN","DGREG",242,0) ;Concurrent processes can check the lock to determine if the patient is "RTN","DGREG",243,0) ;currently being registered. "RTN","DGREG",244,0) ; "RTN","DGREG",245,0) Q:'$G(DFN) 0 "RTN","DGREG",246,0) ; **915, check to see if a query was done within the last 5 minutes so we don't send again "RTN","DGREG",247,0) S DGQRY=$$GET^DGENQRY($$FINDLAST^DGENQRY($G(DFN)),.DGQRY) "RTN","DGREG",248,0) I $$FMDIFF^XLFDT($$NOW^XLFDT,$G(DGQRY("SENT")),2)>300,$$QRY^DGENQRY(DFN) W !!,"Enrollment/Eligibility Query sent ...",!! "RTN","DGREG",249,0) ;patch 886 changed lock to use dilocktm "RTN","DGREG",250,0) L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3) "RTN","DGREG",251,0) I $$LOCK^DGENPTA1(DFN) ;try to lock the patient record "RTN","DGREG",252,0) Q "RTN","DGREG",253,0) ; "RTN","DGREG",254,0) ENDREG(DFN) ; "RTN","DGREG",255,0) ;Description: releases the lock obtained by calling BEGINREG. "RTN","DGREG",256,0) ; "RTN","DGREG",257,0) Q:'$G(DFN) "RTN","DGREG",258,0) L -^TMP(DFN,"REGISTRATION IN PROGRESS") "RTN","DGREG",259,0) D UNLOCK^DGENPTA1(DFN) "RTN","DGREG",260,0) Q "RTN","DGREG",261,0) ; "RTN","DGREG",262,0) IFREG(DFN) ; "RTN","DGREG",263,0) ;Description: tests whether the lock set by BEGINREG is set "RTN","DGREG",264,0) ; "RTN","DGREG",265,0) ;Input: DFN "RTN","DGREG",266,0) ;Output: "RTN","DGREG",267,0) ; Function Value = 1 if lock is set, 0 otherwise "RTN","DGREG",268,0) ; "RTN","DGREG",269,0) N RETURN "RTN","DGREG",270,0) Q:'$G(DFN) 0 "RTN","DGREG",271,0) ;patch 886 changed lock to use dilocktm "RTN","DGREG",272,0) L +^TMP(DFN,"REGISTRATION IN PROGRESS"):$G(DILOCKTM,3) "RTN","DGREG",273,0) S RETURN='$T "RTN","DGREG",274,0) L -^TMP(DFN,"REGISTRATION IN PROGRESS") "RTN","DGREG",275,0) Q RETURN "RTN","DGREG",276,0) Q "RTN","DGREG",277,0) CIRN ;MPI QUERY "RTN","DGREG",278,0) ;check to see if CIRN PD/MPI is installed "RTN","DGREG",279,0) N X S X="MPIFAPI" X ^%ZOSF("TEST") Q:'$T "RTN","DGREG",280,0) K MPIFRTN "RTN","DGREG",281,0) D MPIQ^MPIFAPI(DFN) "RTN","DGREG",282,0) K MPIFRTN "RTN","DGREG",283,0) Q "RTN","DGREG",284,0) ROMQRY ;**926 TRIGGER IB INSURANCE QUERY "RTN","DGREG",285,0) N ZTSAVE,A,ZTRTN,ZTDESC,ZTIO,ZTDTH,DGMSG "RTN","DGREG",286,0) ;Invoke IB Insurance Query (Patch IB*2.0*214) "RTN","DGREG",287,0) S ZTSAVE("IBTYPE")=1,ZTSAVE("DFN")=DFN,ZTSAVE("IBDUZ")=$G(DUZ) "RTN","DGREG",288,0) S ZTRTN="BACKGND^IBCNRDV",ZTDTH=$H,ZTDESC="IBCN INSURANCE QUERY TASK",ZTIO="" "RTN","DGREG",289,0) D ^%ZTLOAD "RTN","DGREG",290,0) ;display busy message to interactive users "RTN","DGREG",291,0) S DGMSG(1)="Insurance data retrieval has been initiated." "RTN","DGREG",292,0) S DGMSG(2)=" " "RTN","DGREG",293,0) D EN^DDIOL(.DGMSG) "RTN","DGREG",294,0) Q ;**915 all register once functionality no longer executed. "RTN","DGREG",295,0) I +$G(DGNEW) D "RTN","DGREG",296,0) . ; query LST for Patient Demographic Information if NEW patient and "RTN","DGREG",297,0) . ; file into patient's record. "RTN","DGREG",298,0) . N A "RTN","DGREG",299,0) . I $$ROMQRY^DGROAPI(DFN) D "RTN","DGREG",300,0) . . ;display busy message to interactive users "RTN","DGREG",301,0) . .S DGMSG(1)="Data retrieval from LST site has been completed successfully" "RTN","DGREG",302,0) . .S DGMSG(2)="Thank you for your patience." "RTN","DGREG",303,0) . .D EN^DDIOL(.DGMSG) R A:5 "RTN","DGREG",304,0) . E D "RTN","DGREG",305,0) . . ;display busy message to interactive users "RTN","DGREG",306,0) . .S DGMSG(1)="Data retrieval from LST site has not been successful." "RTN","DGREG",307,0) . .S DGMSG(2)="Please continue the Registration Process." "RTN","DGREG",308,0) . .D EN^DDIOL(.DGMSG) R A:5 "RTN","DGREG",309,0) . ; "RTN","DGREG",310,0) Q "RTN","DGREGAED") 0^7^B71144811^B62965158 "RTN","DGREGAED",1,0) DGREGAED ;ALB/DW/PHH,BAJ,TDM,JAM - Address Edit API ;1/6/21 10:28 "RTN","DGREGAED",2,0) ;;5.3;Registration;**522,560,658,730,688,808,915,941,1010,1014,1040**;Aug 13, 1993;Build 15 "RTN","DGREGAED",3,0) ;; "RTN","DGREGAED",4,0) ;; **688** Modifications for Country and Foreign address "RTN","DGREGAED",5,0) ;; **915** Make DFN optional in case one is not established yet "RTN","DGREGAED",6,0) ; "RTN","DGREGAED",7,0) EN(DFN,FLG,SRC,DGRET) ;Entry point "RTN","DGREGAED",8,0) ;Input: "RTN","DGREGAED",9,0) ; DFN (optional) - Internal Entry # of Patient File (#2) "RTN","DGREGAED",10,0) ; If not supplied then nothing filed or defaulted "RTN","DGREGAED",11,0) ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details: "RTN","DGREGAED",12,0) ; FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132) "RTN","DGREGAED",13,0) ; FLG(2) - if 1 display before & after address for user confirmation "RTN","DGREGAED",14,0) ; DGRET - if passed by reference will contain address info array "RTN","DGREGAED",15,0) K EASZIPLK,DGRET "RTN","DGREGAED",16,0) N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC "RTN","DGREGAED",17,0) N I,X,Y "RTN","DGREGAED",18,0) S DFN=+$G(DFN) "RTN","DGREGAED",19,0) ;I ($G(DFN)'?.N) Q "RTN","DGREGAED",20,0) S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2)) "RTN","DGREGAED",21,0) D GETOLD(.DGCMP,DFN) "RTN","DGREGAED",22,0) S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.11)),"^",10),1:"") "RTN","DGREGAED",23,0) I ICNTRY="" S ICNTRY=1 ;default country is USA if NULL "RTN","DGREGAED",24,0) ; "RTN","DGREGAED",25,0) ; DG*5.3*1014; jam; ** Start changes ** "RTN","DGREGAED",26,0) RETRY ; DG*5.3*1014;jam ; Tag added for entry point to re-enter the address "RTN","DGREGAED",27,0) ; DG*5.3*1040 - Set variable DGTMOT to 1 to track timeout "RTN","DGREGAED",28,0) S OLDC=DGCMP("OLD",.1173),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.1173,.CNTRY) I FORGN=-1 S DGTMOT=1 Q "RTN","DGREGAED",29,0) S FSTR=$$INPT1(FORGN,.PSTR) ;set up field string of address prompts "RTN","DGREGAED",30,0) S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q "RTN","DGREGAED",31,0) I 'DFN M DGRET=DGINPUT Q "RTN","DGREGAED",32,0) ; DG*5.3*1014; jam; If required fields are missing, we can't call the validation service "RTN","DGREGAED",33,0) I DGINPUT(.111)=""!(DGINPUT(.114)="")!(($G(DGINPUT(.1112))="")&('FORGN)) D G RETRY "RTN","DGREGAED",34,0) . I 'FORGN W !!?3,*7,"ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGAED",35,0) . I FORGN W !!?3,*7,"ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGAED",36,0) ; DG*5.3*1014; Display address entered - user may reenter the address or continue to Validation service. "RTN","DGREGAED",37,0) N DGNEWADD "RTN","DGREGAED",38,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGAED",39,0) W ! "RTN","DGREGAED",40,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGAED",41,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGAED",42,0) K DGNEWADD "RTN","DGREGAED",43,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGAED",44,0) N DIR "RTN","DGREGAED",45,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGAED",46,0) S DIR("A")=" or '^' to quit" "RTN","DGREGAED",47,0) S DIR(0)="FO" "RTN","DGREGAED",48,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit." "RTN","DGREGAED",49,0) D ^DIR K DIR "RTN","DGREGAED",50,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout and QUIT "RTN","DGREGAED",51,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGAED",52,0) ; DG*5.3*1040 - Remove the DTOUT check "RTN","DGREGAED",53,0) I $D(DUOUT) W !,"Address changes not saved." D EOP Q ;Exiting - Not saving address "RTN","DGREGAED",54,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGAED",55,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGAED",56,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGAED",57,0) N DGADVRET "RTN","DGREGAED",58,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"P") "RTN","DGREGAED",59,0) ; if return is -1 timeout occurred "RTN","DGREGAED",60,0) I DGADVRET=-1 S DGTMOT=1 Q "RTN","DGREGAED",61,0) ; if return is 0 - address was not validated "RTN","DGREGAED",62,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP Q:+$G(DGTMOT) ; DG*5.3*1040 - Check EOP timeout and QUIT "RTN","DGREGAED",63,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGAED",64,0) ; "RTN","DGREGAED",65,0) ; DG*5.3*1014; jam; ** End changes ** "RTN","DGREGAED",66,0) ; "RTN","DGREGAED",67,0) CONF I $G(FLG(2))=1 D COMPARE(.DGINPUT,.DGCMP,.FLG) "RTN","DGREGAED",68,0) ; DG*5.3*1040 - Store return value from $$CONFIRM() "RTN","DGREGAED",69,0) N DGCONFIRM S DGCONFIRM=$$CONFIRM() "RTN","DGREGAED",70,0) ; DG*5.3*1040 - Quit if timeout when DGCONFIRM = -1 "RTN","DGREGAED",71,0) Q:DGCONFIRM=-1 "RTN","DGREGAED",72,0) ; DG*5.3*1040 - Check variable DGCONFIRM "RTN","DGREGAED",73,0) I 'DGCONFIRM W !,"Address changes not saved." D EOP Q "RTN","DGREGAED",74,0) N DGPRIOR "RTN","DGREGAED",75,0) D GETPRIOR^DGADDUTL(DFN,.DGPRIOR) "RTN","DGREGAED",76,0) D SAVE(.DGINPUT,DFN,FSTR,FORGN) I $G(SRC)="",+$G(DGNEW) Q "RTN","DGREGAED",77,0) Q:'$$FILEYN^DGADDUTL(.DGPRIOR,.DGINPUT) "RTN","DGREGAED",78,0) D GETUPDTS^DGADDUTL(DFN,.DGINPUT) "RTN","DGREGAED",79,0) D UPDADDLG^DGADDUTL(DFN,.DGPRIOR,.DGINPUT) "RTN","DGREGAED",80,0) Q "RTN","DGREGAED",81,0) INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes "RTN","DGREGAED",82,0) ;Output: DGINPUT(field#)=external^internal(if any) "RTN","DGREGAED",83,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L "RTN","DGREGAED",84,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1 D "RTN","DGREGAED",85,0) . I $$SKIP(DGN,.DGINPUT,.FLG) Q "RTN","DGREGAED",86,0) . ; DG*5.3*1040 - Set timeout variable DGTMOT to 1, if ZIP timeout "RTN","DGREGAED",87,0) . I DGN=.1112 D ZIPINP(.DGINPUT,DFN) S:DGINPUT=-1 DGTMOT=1 Q "RTN","DGREGAED",88,0) . ; DG*5.3*1040 - Set timeout variable DGTMOT to 1, if field timeout "RTN","DGREGAED",89,0) . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1,DGTMOT=1 Q "RTN","DGREGAED",90,0) . I DGN=.121 S Y=$G(Y) D Q "RTN","DGREGAED",91,0) .. I Y="",DGINPUT(DGN)="" Q "RTN","DGREGAED",92,0) .. I DFN,$P(Y,U)=$$GET1^DIQ(2,DFN_",",DGN,"I") S DGINPUT(DGN)=$$GET1^DIQ(2,DFN_",",DGN)_U_$P(Y,U) Q "RTN","DGREGAED",93,0) .. S DGINPUT(DGN)=$P(Y(0),U)_U_Y "RTN","DGREGAED",94,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGAED",95,0) I DGINPUT'=-1 S DGINPUT(.1173)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGAED",96,0) Q "RTN","DGREGAED",97,0) GETOLD(DGCMP,DFN) ;populate array with existing address info "RTN","DGREGAED",98,0) N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY "RTN","DGREGAED",99,0) S CFORGN=0 "RTN","DGREGAED",100,0) ; get current country "RTN","DGREGAED",101,0) ; If current country is NULL it is old data "RTN","DGREGAED",102,0) ; Leave it NULL here because this is not an edit funtion "RTN","DGREGAED",103,0) S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",","COUNTRY","I"),1:"") "RTN","DGREGAED",104,0) ;I CCIEN="" S CCIEN=$O(^HL(779.004,"D","UNITED STATES","")) "RTN","DGREGAED",105,0) S CFORGN=$$FORIEN^DGADDUTL(CCIEN) "RTN","DGREGAED",106,0) ;get current address fields and xlate to ^DIQ format "RTN","DGREGAED",107,0) S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";") "RTN","DGREGAED",108,0) ; Domestic data needs some extra fields "RTN","DGREGAED",109,0) I 'CFORGN S CFSTR=CFSTR_";.114;.115;.117" "RTN","DGREGAED",110,0) I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR") "RTN","DGREGAED",111,0) F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E")) "RTN","DGREGAED",112,0) S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY" "RTN","DGREGAED",113,0) S DGCMP("OLD",.1173)=COUNTRY_"^"_CCIEN "RTN","DGREGAED",114,0) I 'CFORGN D "RTN","DGREGAED",115,0) . S DGCIEN=$G(DGCURR(2,DFN_",",.117,"I")) "RTN","DGREGAED",116,0) . S DGST=$G(DGCURR(2,DFN_",",.115,"I")) "RTN","DGREGAED",117,0) . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) "RTN","DGREGAED",118,0) . I DGCNTY=-1 S DGCNTY="" "RTN","DGREGAED",119,0) . S DGCMP("OLD",.117)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3) "RTN","DGREGAED",120,0) Q "RTN","DGREGAED",121,0) ; "RTN","DGREGAED",122,0) COMPARE(DGINPUT,DGCMP,FLG) ;Display before & after address fields. "RTN","DGREGAED",123,0) N DGM "RTN","DGREGAED",124,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGAED",125,0) F DGM="OLD","NEW" D "RTN","DGREGAED",126,0) . I DGCMP(DGM,.1173)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.1173),U,2)) D DISPFGN(.DGCMP,DGM,.FLG) Q "RTN","DGREGAED",127,0) . I DGM="NEW" D "RTN","DGREGAED",128,0) . . S DGCNTY=$P($G(DGCMP("NEW",.117)),U)_" "_$P($G(DGCMP("NEW",.117)),U,3) "RTN","DGREGAED",129,0) . . S DGCMP("NEW",.117)=DGCNTY "RTN","DGREGAED",130,0) . . I ($L(DGCMP("NEW",.1112))>5)&($P(DGCMP("NEW",.1112),"-",2)="") S DGCMP("NEW",.1112)=$E(DGCMP("NEW",.1112),1,5)_"-"_$E(DGCMP("NEW",.1112),6,9) "RTN","DGREGAED",131,0) . D DISPUS(.DGCMP,DGM,.FLG) "RTN","DGREGAED",132,0) Q "RTN","DGREGAED",133,0) ; "RTN","DGREGAED",134,0) DISPUS(DGCMP,DGM,FLG) ;tag to display US data "RTN","DGREGAED",135,0) N DGCNTRY "RTN","DGREGAED",136,0) W !,?2,"[",DGM," ADDRESS]" "RTN","DGREGAED",137,0) W ?16,$P($G(DGCMP(DGM,.111)),U) "RTN","DGREGAED",138,0) I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U) "RTN","DGREGAED",139,0) I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U) "RTN","DGREGAED",140,0) W !,?16,$P($G(DGCMP(DGM,.114)),U) "RTN","DGREGAED",141,0) W:($P($G(DGCMP(DGM,.114)),U)'="")!($P($G(DGCMP(DGM,.115)),U)'="") "," "RTN","DGREGAED",142,0) W $P($G(DGCMP(DGM,.115)),U) "RTN","DGREGAED",143,0) W " ",$G(DGCMP(DGM,.1112)) "RTN","DGREGAED",144,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2)) "RTN","DGREGAED",145,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGAED",146,0) I $P($G(DGCMP(DGM,.117)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.117)),U) "RTN","DGREGAED",147,0) I $G(FLG(1))=1 D "RTN","DGREGAED",148,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGAED",149,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGAED",150,0) W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U) "RTN","DGREGAED",151,0) W ! "RTN","DGREGAED",152,0) Q "RTN","DGREGAED",153,0) ; "RTN","DGREGAED",154,0) DISPFGN(DGCMP,DGM,FLG) ;tag to display Foreign data "RTN","DGREGAED",155,0) N DGCNTRY "RTN","DGREGAED",156,0) W !,?2,"[",DGM," ADDRESS]" "RTN","DGREGAED",157,0) W ?16,$P($G(DGCMP(DGM,.111)),U) "RTN","DGREGAED",158,0) I $P($G(DGCMP(DGM,.112)),U)'="" W !,?16,$P($G(DGCMP(DGM,.112)),U) "RTN","DGREGAED",159,0) I $P($G(DGCMP(DGM,.113)),U)'="" W !,?16,$P($G(DGCMP(DGM,.113)),U) "RTN","DGREGAED",160,0) ;W !,?16,$P($G(DGCMP(DGM,.1172)),U)_" "_$P($G(DGCMP(DGM,.114)),U)_" "_$P($G(DGCMP(DGM,.1171)),U) ;DG*1010 comment out "RTN","DGREGAED",161,0) W !,?16,$P($G(DGCMP(DGM,.114)),U)_" "_$P($G(DGCMP(DGM,.1171)),U)_" "_$P($G(DGCMP(DGM,.1172)),U) ; DG*1010 - display postal code last "RTN","DGREGAED",162,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.1173)),U,2)) "RTN","DGREGAED",163,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGAED",164,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGAED",165,0) I $G(FLG(1))=1 D "RTN","DGREGAED",166,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGAED",167,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGAED",168,0) W !,?6,"Bad Addr: ",?16,$P($G(DGCMP(DGM,.121)),U) "RTN","DGREGAED",169,0) W ! "RTN","DGREGAED",170,0) Q "RTN","DGREGAED",171,0) ; "RTN","DGREGAED",172,0) CONFIRM() ;Confirm if user wants to save the change "RTN","DGREGAED",173,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT "RTN","DGREGAED",174,0) S DIR(0)="Y" "RTN","DGREGAED",175,0) S DIR("A")="Are you sure that you want to save the above changes" "RTN","DGREGAED",176,0) S DIR("?")="Please answer Y for YES or N for NO." "RTN","DGREGAED",177,0) D ^DIR "RTN","DGREGAED",178,0) ; DG*5.3*1040 - If timeout set DGTMOT=1 and return -1 "RTN","DGREGAED",179,0) I $D(DTOUT) S DGTMOT=1 Q -1 "RTN","DGREGAED",180,0) ; DG*5.3*1040 - Remove the DTOUT check "RTN","DGREGAED",181,0) I $G(Y)=0 Q 0 "RTN","DGREGAED",182,0) I $D(DUOUT)!$D(DIROUT) Q 0 "RTN","DGREGAED",183,0) Q 1 "RTN","DGREGAED",184,0) SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes "RTN","DGREGAED",185,0) N DGN,DGER,DGM,L,DATA "RTN","DGREGAED",186,0) S DGER=0 "RTN","DGREGAED",187,0) ; need to get the country code into the DGINPUT array "RTN","DGREGAED",188,0) ; if it's a domestic address, we have to add in CITY,STATE & COUNTY "RTN","DGREGAED",189,0) S FSTR=FSTR_$S('FORGN:",.114,.115,.117,.1173",1:",.1173") "RTN","DGREGAED",190,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D "RTN","DGREGAED",191,0) . I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) Q "RTN","DGREGAED",192,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGAED",193,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGAED",194,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGAED",195,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGAED",196,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGAED",197,0) . I $D(MSG) D "RTN","DGREGAED",198,0) .. S DGM="",DGER=1 "RTN","DGREGAED",199,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGAED",200,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGAED",201,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGAED",202,0) I $G(DGER)=0 W !,"Change saved." D "RTN","DGREGAED",203,0) .;JAM, Set the CASS value for Perm Mailing Address ;DG*5.3*941 "RTN","DGREGAED",204,0) . S DATA(.1118)="NC" "RTN","DGREGAED",205,0) . I $$UPD^DGENDBS(2,DFN,.DATA) "RTN","DGREGAED",206,0) D EOP "RTN","DGREGAED",207,0) Q "RTN","DGREGAED",208,0) READ(DFN,DGN,Y) ;Read input, return success "RTN","DGREGAED",209,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP "RTN","DGREGAED",210,0) S SUCCESS=1,POP=0 "RTN","DGREGAED",211,0) F L=0:0 D Q:POP "RTN","DGREGAED",212,0) . S DIR(0)=2_","_DGN "RTN","DGREGAED",213,0) . I DFN S DA=DFN "RTN","DGREGAED",214,0) . D ^DIR "RTN","DGREGAED",215,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGAED",216,0) . I $D(DUOUT)!$D(DIROUT) D UPCT Q "RTN","DGREGAED",217,0) . S POP=1 "RTN","DGREGAED",218,0) Q SUCCESS "RTN","DGREGAED",219,0) INPT1(FORGN,PSTR) ; first address input prompts "RTN","DGREGAED",220,0) N FSTR "RTN","DGREGAED",221,0) ; PSTR is the full set of fields domestic & foreign combined "RTN","DGREGAED",222,0) ; FSTR is the set of fields depending on Country code "RTN","DGREGAED",223,0) S PSTR=".111,.112,.113,.114,.115,.117,.1112,.1171,.1172,.1173,.131,.132,.121" "RTN","DGREGAED",224,0) S FSTR=".111,.112,.113,.1112,.131,.132,.121" "RTN","DGREGAED",225,0) I FORGN S FSTR=".111,.112,.113,.114,.1171,.1172,.131,.132,.121" "RTN","DGREGAED",226,0) Q FSTR "RTN","DGREGAED",227,0) ZIPINP(DGINPUT,DFN) ; get ZIP+4 input "RTN","DGREGAED",228,0) N DGR "RTN","DGREGAED",229,0) D EN^DGREGAZL(.DGR,DFN) "RTN","DGREGAED",230,0) ;DG*5.3*1014 - Zip entry failed (due to timeout, or ^ entry, or input error) - before the Quit, set DGINPUT=-1 "RTN","DGREGAED",231,0) ;I $G(DGR)=-1 Q "RTN","DGREGAED",232,0) I $G(DGR)=-1 S DGINPUT=-1 Q "RTN","DGREGAED",233,0) M DGINPUT=DGR "RTN","DGREGAED",234,0) Q "RTN","DGREGAED",235,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGAED",236,0) N SKIP "RTN","DGREGAED",237,0) S SKIP=0 "RTN","DGREGAED",238,0) I ($G(DGINPUT(.111))="")&((DGN=.112)!(DGN=.113)) S SKIP=1 "RTN","DGREGAED",239,0) I ($G(DGINPUT(.112))="")&(DGN=.113) S SKIP=1 "RTN","DGREGAED",240,0) I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1 "RTN","DGREGAED",241,0) Q SKIP "RTN","DGREGAED",242,0) EOP ;End of page prompt "RTN","DGREGAED",243,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGAED",244,0) S DIR(0)="E" "RTN","DGREGAED",245,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGAED",246,0) D ^DIR "RTN","DGREGAED",247,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGAED",248,0) S:$D(DTOUT) DGTMOT=1 "RTN","DGREGAED",249,0) Q "RTN","DGREGAED",250,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGAED",251,0) W !,"EXIT NOT ALLOWED ??" "RTN","DGREGAED",252,0) Q "RTN","DGREGCP1") 0^9^B34041962^B30297133 "RTN","DGREGCP1",1,0) DGREGCP1 ;ALB/CLT - ADDRESS COPY UTILITIES ; 18 May 2017 2:54 PM "RTN","DGREGCP1",2,0) ;;5.3;Registration;**941,1010,1040**;Aug 13, 1993;Build 15 "RTN","DGREGCP1",3,0) ; "RTN","DGREGCP1",4,0) RESDISP(DFN) ;DISPLAY THE RESIDENTIAL ADDRESS "RTN","DGREGCP1",5,0) N DGA1,DGA2,DGA3,DGA4,DGA9,DGA10,DGA1315,DGZIP "RTN","DGREGCP1",6,0) N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY "RTN","DGREGCP1",7,0) W !,"Residential Address to copy to the Permanent Mailing Address:",! "RTN","DGREGCP1",8,0) I $G(^DPT(DFN,.115))="" D Q "RTN","DGREGCP1",9,0) .W !?5,"NO RESIDENTIAL ADDRESS" "RTN","DGREGCP1",10,0) ;DISPLAY THE CURRENT RESIDENTIAL ADDRESS "RTN","DGREGCP1",11,0) S DGXX=^DPT(DFN,.115),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4) "RTN","DGREGCP1",12,0) S DGA9=$P(DGXX,"^",9) "RTN","DGREGCP1",13,0) S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10="" "RTN","DGREGCP1",14,0) S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10) "RTN","DGREGCP1",15,0) I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY" "RTN","DGREGCP1",16,0) W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3 "RTN","DGREGCP1",17,0) ;FORDISP ;DISPLAY FOREIGN ADDRESS "RTN","DGREGCP1",18,0) I DGA1="" W ! "RTN","DGREGCP1",19,0) I 'DGFORGN D "RTN","DGREGCP1",20,0) . W ?43,"County: " "RTN","DGREGCP1",21,0) . I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q "RTN","DGREGCP1",22,0) . I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D "RTN","DGREGCP1",23,0) .. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7) "RTN","DGREGCP1",24,0) .. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")" "RTN","DGREGCP1",25,0) E D "RTN","DGREGCP1",26,0) . W ?43,"Province: " "RTN","DGREGCP1",27,0) . W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN") "RTN","DGREGCP1",28,0) ;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out "RTN","DGREGCP1",29,0) I DGFORGN W !?3,DGA4_" "_DGA9 ;DG*1010 - display postal code last "RTN","DGREGCP1",30,0) I 'DGFORGN W !?3,DGA4 D "RTN","DGREGCP1",31,0) . I $D(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.115),"^",5),0),"^",2) "RTN","DGREGCP1",32,0) . S DGZIP=$P(^DPT(DFN,.115),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12) "RTN","DGREGCP1",33,0) . W " ",DGZIP "RTN","DGREGCP1",34,0) W !?3,DGCNTRY,! "RTN","DGREGCP1",35,0) Q "RTN","DGREGCP1",36,0) ; "RTN","DGREGCP1",37,0) PERMDISP(DFN) ;DISPLAY PERMANENT MAILING ADDRESS "RTN","DGREGCP1",38,0) N DGA1,DGA9,DGA10,DGA1315,DGA2,DGA3,DGA4,DGZIP "RTN","DGREGCP1",39,0) N DGE,DGXX,DGFORGN,X,Y,DGCIEN,DGST,DGCNTRY,DGCNTY "RTN","DGREGCP1",40,0) W !,"Permanent Mailing Address to copy to Residential Address:",! "RTN","DGREGCP1",41,0) I $G(^DPT(DFN,.11))="" D Q "RTN","DGREGCP1",42,0) .W !?5,"NO PERMANENT MAILING ADDRESS" "RTN","DGREGCP1",43,0) ;DISPLAY THE CURRENT PERMANENT MAILING ADDRESS "RTN","DGREGCP1",44,0) S DGXX=^DPT(DFN,.11),DGA1=$P(DGXX,"^",1),DGA2=$P(DGXX,"^",2),DGA3=$P(DGXX,"^",3),DGA4=$P(DGXX,"^",4) "RTN","DGREGCP1",45,0) S DGA9=$P(DGXX,"^",9) "RTN","DGREGCP1",46,0) S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10="" "RTN","DGREGCP1",47,0) S DGCNTRY=$E($$CNTRYI^DGADDUTL(DGA10),1,25),DGFORGN=$$FORIEN^DGADDUTL(DGA10) "RTN","DGREGCP1",48,0) I DGCNTRY=-1 S DGCNTRY="UNKNOWN COUNTRY" "RTN","DGREGCP1",49,0) W:DGA1'="" !?3,DGA1 W:$G(DGA2)'="" !?3,DGA2 W:$G(DGA3)'="" !?3,DGA3 "RTN","DGREGCP1",50,0) ;FORGNCHK ;CHECK FOR FOREIGN ADDRESS "RTN","DGREGCP1",51,0) I DGA1="" W ! "RTN","DGREGCP1",52,0) I 'DGFORGN D "RTN","DGREGCP1",53,0) . W ?43,"County: " "RTN","DGREGCP1",54,0) . I $P(DGXX,U,5)=""!($P(DGXX,U,7)="") W "UNKNOWN" Q "RTN","DGREGCP1",55,0) . I $P(DGXX,U,7)'="" I $D(^DIC(5,$P(DGXX,U,5),1,$P(DGXX,U,7),0)) D "RTN","DGREGCP1",56,0) .. S DGST=$P(DGXX,U,5),DGCIEN=$P(DGXX,U,7) "RTN","DGREGCP1",57,0) .. S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) W $P(DGCNTY,"^",1),"(",$P(DGCNTY,"^",3),")" "RTN","DGREGCP1",58,0) E D "RTN","DGREGCP1",59,0) . W ?43,"Province: " "RTN","DGREGCP1",60,0) . W $S($P(DGXX,U,8)'="":$P(DGXX,U,8),1:"UNKNOWN") "RTN","DGREGCP1",61,0) ;I DGFORGN W !?3,DGA9_" "_DGA4 ;DG*1010 comment out "RTN","DGREGCP1",62,0) I DGFORGN W !?3,DGA4_" "_DGA9 ;DG*1010 - display postal code last "RTN","DGREGCP1",63,0) I 'DGFORGN W !?3,DGA4 D "RTN","DGREGCP1",64,0) . I $D(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0)) W ",",$P(^DIC(5,+$P(^DPT(DFN,.11),"^",5),0),"^",2) "RTN","DGREGCP1",65,0) . S DGZIP=$P(^DPT(DFN,.11),"^",6) I $L(DGZIP)>5 S DGZIP=$E(DGZIP,1,5)_"-"_$E(DGZIP,6,12) "RTN","DGREGCP1",66,0) . W " ",DGZIP "RTN","DGREGCP1",67,0) W !?3,DGCNTRY,! "RTN","DGREGCP1",68,0) Q "RTN","DGREGCP1",69,0) ; "RTN","DGREGCP1",70,0) RESMVQ(DFN) ;DISPLAY RESIDENTIAL ADDRESS AND QUESTION IF COPY TO PERM IS DESIRED "RTN","DGREGCP1",71,0) I $G(^DPT(DFN,.115))="" Q "RTN","DGREGCP1",72,0) N DIR,X,Y,DTOUT,DUOUT "RTN","DGREGCP1",73,0) S DIR(0)="Y",DIR("A")="Copy the Residential Address to the Permanent Mailing Address",DIR("B")="NO" "RTN","DGREGCP1",74,0) S DIR("?",1)="Enter 'YES' to copy the Residential Address ",DIR("?")="to the Permanent Mailing Address." "RTN","DGREGCP1",75,0) D ^DIR "RTN","DGREGCP1",76,0) ; DG*5.3*1040 - Check for timeout of the Copy prompt "RTN","DGREGCP1",77,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGCP1",78,0) I $G(Y)=1 D "RTN","DGREGCP1",79,0) . W ! "RTN","DGREGCP1",80,0) . D RESDISP(DFN) "RTN","DGREGCP1",81,0) . S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")="" "RTN","DGREGCP1",82,0) . S DIR("?",1)="If you answer 'YES' the current Residential Address will be copied",DIR("?")="to the Permanent Mailing Address." "RTN","DGREGCP1",83,0) . D ^DIR "RTN","DGREGCP1",84,0) . ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGCP1",85,0) . I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGCP1",86,0) . ; DG*5.3*1040 - QUIT if variable Y = 0 "RTN","DGREGCP1",87,0) . Q:$G(Y)=0 "RTN","DGREGCP1",88,0) . I $D(DUOUT)!$D(DIROUT) Q "RTN","DGREGCP1",89,0) . D R2P^DGREGCOP(DFN) "RTN","DGREGCP1",90,0) . W !,"Copy completed." "RTN","DGREGCP1",91,0) . D EOP "RTN","DGREGCP1",92,0) Q "RTN","DGREGCP1",93,0) ; "RTN","DGREGCP1",94,0) PERMMVQ(DFN) ;DISPLAY PERMANENT ADDRESS AND QUESTION IF COPY TO RESIDENTIAL IS DESIRED "RTN","DGREGCP1",95,0) ; First check for a valid Permanent Address that can be copied to residential address "RTN","DGREGCP1",96,0) N DGXX,DGA10,DFORGN "RTN","DGREGCP1",97,0) S DGXX=$G(^DPT(DFN,.11)) "RTN","DGREGCP1",98,0) ; Quit if nothing in Perm address line 1 field "RTN","DGREGCP1",99,0) I $P(DGXX,"^",1)="" Q "RTN","DGREGCP1",100,0) ; Quit if nothing in Perm address City field "RTN","DGREGCP1",101,0) I $P(DGXX,"^",4)="" Q "RTN","DGREGCP1",102,0) ; Quit if no Perm address zipcode defined for a domestic address "RTN","DGREGCP1",103,0) S DGA10=$P(DGXX,"^",10) S:'DGA10 DGA10="" "RTN","DGREGCP1",104,0) S DGFORGN=$$FORIEN^DGADDUTL(DGA10) "RTN","DGREGCP1",105,0) I 'DGFORGN&($P(DGXX,"^",6)="") Q "RTN","DGREGCP1",106,0) ; required address fields exist for copying to Residential address "RTN","DGREGCP1",107,0) ; now check for PO Box or General Delivery address and notify user if not valid address and quit "RTN","DGREGCP1",108,0) N DGADD,DIR,X,Y,DGRESADD,DGRESX "RTN","DGREGCP1",109,0) K DIRUT "RTN","DGREGCP1",110,0) I $$POBOXPM^DGREGCP2(DFN) D Q "RTN","DGREGCP1",111,0) . W !!?3,*7,"P.O. Box and GENERAL DELIVERY cannot be used in residential address." W ! "RTN","DGREGCP1",112,0) . W !,"Because the Permanent Mailing Address line 1 contains P.O. Box" "RTN","DGREGCP1",113,0) . W " or General",!,"Delivery the Permanent Mailing Address cannot be copied to" "RTN","DGREGCP1",114,0) . W !,"the Residential Address." "RTN","DGREGCP1",115,0) . D EOP "RTN","DGREGCP1",116,0) . ; DG*5.3*1040 - Check for timeout "RTN","DGREGCP1",117,0) . Q:+$G(DGTMOT) "RTN","DGREGCP1",118,0) ; Perm address is valid for use as a Residential address "RTN","DGREGCP1",119,0) ASK ; "RTN","DGREGCP1",120,0) W ! "RTN","DGREGCP1",121,0) S DIR(0)="Y",DIR("A")="Copy the Permanent Mailing Address to the Residential Address" "RTN","DGREGCP1",122,0) S DIR("?",1)="Answer 'YES' or 'NO'. 'YES' will copy the current Permanent Mailing Address",DIR("?")="to the Residential Address." "RTN","DGREGCP1",123,0) D ^DIR "RTN","DGREGCP1",124,0) I X="Y"!(X="YES") S Y=1,Y(0)="YES" "RTN","DGREGCP1",125,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGCP1",126,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGCP1",127,0) ; DG*5.3*1040 - QUIT if Y = 0 "RTN","DGREGCP1",128,0) Q:$G(Y)=0 "RTN","DGREGCP1",129,0) I $D(DUOUT)!$D(DIROUT) Q "RTN","DGREGCP1",130,0) I $D(DIRUT) G ASK "RTN","DGREGCP1",131,0) I Y=1 D "RTN","DGREGCP1",132,0) . W ! "RTN","DGREGCP1",133,0) . D PERMDISP(DFN) ;; W !! D RESDISP(DFN) W ! "RTN","DGREGCP1",134,0) . S DIR(0)="Y",DIR("A")="Are you sure you want to copy",DIR("B")="" "RTN","DGREGCP1",135,0) . S DIR("?",1)="If you answer 'YES' the current Permanent Mailing Address will be copied",DIR("?")="to the Residential Address." "RTN","DGREGCP1",136,0) . D ^DIR "RTN","DGREGCP1",137,0) . ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGCP1",138,0) . I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGCP1",139,0) . ; DG*5.3*1040 - QUIT if Y = 0 "RTN","DGREGCP1",140,0) . Q:$G(Y)=0 "RTN","DGREGCP1",141,0) . I $D(DUOUT)!$D(DIROUT) Q "RTN","DGREGCP1",142,0) . D P2R^DGREGCOP(DFN) "RTN","DGREGCP1",143,0) . W !,"Copy completed." "RTN","DGREGCP1",144,0) . D EOP "RTN","DGREGCP1",145,0) ; DG*5.3*1040 - Check for timeout "RTN","DGREGCP1",146,0) Q:+$G(DGTMOT) "RTN","DGREGCP1",147,0) Q "RTN","DGREGCP1",148,0) EOP ;End of page prompt "RTN","DGREGCP1",149,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGCP1",150,0) S DIR(0)="E" "RTN","DGREGCP1",151,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGCP1",152,0) D ^DIR "RTN","DGREGCP1",153,0) ; DG*5.3*1040 - Set variable DGTMOT=1 to track timeout "RTN","DGREGCP1",154,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGCP1",155,0) Q "RTN","DGREGRED") 0^6^B89579662^B77348398 "RTN","DGREGRED",1,0) DGREGRED ;ALB/JAM - Residential Address Edit API ;1/6/21 10:30 "RTN","DGREGRED",2,0) ;;5.3;Registration;**941,1010,1014,1040**;Aug 13, 1993;Build 15 "RTN","DGREGRED",3,0) ;; "RTN","DGREGRED",4,0) ; "RTN","DGREGRED",5,0) EN(DFN,FLG) ;Entry point "RTN","DGREGRED",6,0) ;Input: "RTN","DGREGRED",7,0) ; DFN (required) - Internal Entry # of Patient File (#2) "RTN","DGREGRED",8,0) ; FLG (optional) - Flags of 1 or 0; if null, 0 is assumed. Details: "RTN","DGREGRED",9,0) ; FLG(1) - if 1 let user edit phone numbers (field #.131 and #.132) "RTN","DGREGRED",10,0) ; FLG(2) - if 1 display before & after address (and phone if FLG(1)=1) for user confirmation "RTN","DGREGRED",11,0) N DGINPUT,DGCMP,ICNTRY,CNTRY,FORGN,PSTR,OLDC,FSTR,BAD "RTN","DGREGRED",12,0) N I,X,Y "RTN","DGREGRED",13,0) I $G(DFN)="" Q "RTN","DGREGRED",14,0) S FLG(1)=$G(FLG(1)),FLG(2)=$G(FLG(2)) "RTN","DGREGRED",15,0) RETRY ; Entry point if address must be re-entered "RTN","DGREGRED",16,0) D GETOLD(.DGCMP,DFN) "RTN","DGREGRED",17,0) S CNTRY="",ICNTRY=$S(DFN:$P($G(^DPT(DFN,.115)),"^",10),1:"") "RTN","DGREGRED",18,0) I ICNTRY="" S ICNTRY=1 ;default country is USA if NULL "RTN","DGREGRED",19,0) ; DG*5.3*1040 - Set variable DGTMOT to 1 to track timeout "RTN","DGREGRED",20,0) S OLDC=DGCMP("OLD",.11573),FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,.11573,.CNTRY) I FORGN=-1 S DGTMOT=1 Q "RTN","DGREGRED",21,0) K FSTR,PSTR S FSTR=$$INPT1(FORGN,.PSTR) ;set up field string of address prompts "RTN","DGREGRED",22,0) K DGINPUT S DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR,CNTRY) I $G(DGINPUT)=-1 Q "RTN","DGREGRED",23,0) ; initialize valid address flag "RTN","DGREGRED",24,0) S BAD=0 "RTN","DGREGRED",25,0) ; "RTN","DGREGRED",26,0) ; **** DG*5.3*1014; jam; Start changes **** "RTN","DGREGRED",27,0) ; "RTN","DGREGRED",28,0) ; DG*5.3*1014; jam; If required fields are missing, we can't call the validation service - force user to correct the address "RTN","DGREGRED",29,0) I DGINPUT(.1151)=""!(DGINPUT(.1154)="")!(($G(DGINPUT(.1156))="")&('FORGN)) D G RETRY "RTN","DGREGRED",30,0) . I 'FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGRED",31,0) . I FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGRED",32,0) ; DG*5.3*1014; Display the address entered "RTN","DGREGRED",33,0) N DGNEWADD "RTN","DGREGRED",34,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGRED",35,0) W ! "RTN","DGREGRED",36,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGRED",37,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGRED",38,0) K DGNEWADD "RTN","DGREGRED",39,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGRED",40,0) N DIR "RTN","DGREGRED",41,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGRED",42,0) S DIR("A")=" or '^' to quit" "RTN","DGREGRED",43,0) S DIR(0)="FO" "RTN","DGREGRED",44,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit.." "RTN","DGREGRED",45,0) D ^DIR K DIR "RTN","DGREGRED",46,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout and QUIT "RTN","DGREGRED",47,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGRED",48,0) ; DG*5.3*1040 - Remove the DTOUT check and Quit if EOP timeout "RTN","DGREGRED",49,0) I $D(DUOUT) W !,"Address changes not saved." D EOP Q:+$G(DGTMOT) G PHONE ;Exiting - Not saving address - go to phone saving process "RTN","DGREGRED",50,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGRED",51,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGRED",52,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGRED",53,0) N DGADVRET "RTN","DGREGRED",54,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"R") "RTN","DGREGRED",55,0) ; DG*5.3*1040; if return is -1 timeout occurred "RTN","DGREGRED",56,0) I DGADVRET=-1 S DGTMOT=1 Q "RTN","DGREGRED",57,0) ; if return is 0 - address was not validated "RTN","DGREGRED",58,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP Q:+$G(DGTMOT) ; DG*5.3*1040 - Check EOP timeout and QUIT "RTN","DGREGRED",59,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGRED",60,0) ; "RTN","DGREGRED",61,0) ; **** DG*5.3*1014; jam; End changes **** "RTN","DGREGRED",62,0) ; "RTN","DGREGRED",63,0) ; if flag is set, show old and new address "RTN","DGREGRED",64,0) I FLG(2)=1 D COMPARE(.DGINPUT,.DGCMP) "RTN","DGREGRED",65,0) ; DG*5.3*1040 - Use variable DGCONFIRM to hold value of $$CONFIRM("ADDRESS") "RTN","DGREGRED",66,0) N DGCONFIRM S DGCONFIRM=$$CONFIRM("ADDRESS") I DGCONFIRM=-1 S DGTMOT=1 Q "RTN","DGREGRED",67,0) ; DG*5.3*1040 - Check variable DGCONFIRM "RTN","DGREGRED",68,0) I 'DGCONFIRM W !,"Address changes not saved." G PHONE ;Not saving address - go to phone saving process "RTN","DGREGRED",69,0) ; Validate the address fields and set BAD=1 if not valid "RTN","DGREGRED",70,0) I DGINPUT(.1151)=""!(DGINPUT(.1154)="")!(($G(DGINPUT(.1156))="")&('FORGN)) D S BAD=1 G PHONE "RTN","DGREGRED",71,0) . I 'FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1], ZIP CODE and CITY fields are required." "RTN","DGREGRED",72,0) . I FORGN W !!?3,*7,"RESIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGRED",73,0) ; If address is valid, next check is for PO Box and General Delivery - "RTN","DGREGRED",74,0) ; Pass in LINE 1, State and Country codes "RTN","DGREGRED",75,0) I $$POBOXRES^DGREGCP2(DGINPUT(.1151),$P($G(DGINPUT(.1155)),"^",2),$P(DGINPUT(.11573),"^",2)) D S BAD=1 G PHONE "RTN","DGREGRED",76,0) . W !!?3,*7,"You cannot enter 'P. O. Box' or 'General Delivery' for a Residential Address." "RTN","DGREGRED",77,0) ; If all Validations passed - save the address "RTN","DGREGRED",78,0) D SAVE(.DGINPUT,DFN,FSTR,FORGN) Q:+$G(DGTMOT) "RTN","DGREGRED",79,0) PHONE ; Process the phone number changes IF FLG(1) = 1 "RTN","DGREGRED",80,0) I $G(FLG(1))=1 D "RTN","DGREGRED",81,0) . ; if compare flag is set, display old/new values "RTN","DGREGRED",82,0) . I $G(FLG(2))=1 D COMPAREP(.DGINPUT,.DGCMP) "RTN","DGREGRED",83,0) . ; DG*5.3*1040 - Use variable DGCONFIRM to hold value of $$CONFIRM("PHONE") "RTN","DGREGRED",84,0) . N DGCONFIRM S DGCONFIRM=$$CONFIRM("PHONE") I DGCONFIRM=-1 S DGTMOT=1 Q "RTN","DGREGRED",85,0) . ; DG*5.3*1040 - Check variable DGCONFIRM and DGTMOT "RTN","DGREGRED",86,0) . I 'DGCONFIRM W !,"Phone changes not saved." D EOP Q:+$G(DGTMOT) "RTN","DGREGRED",87,0) . E D SAVEPH(.DGINPUT,DFN) Q:+$G(DGTMOT) ; DG*5.3*1040 - QUIT if timeout "RTN","DGREGRED",88,0) ; Phone number process is completed - go to RETRY if address validation failed "RTN","DGREGRED",89,0) I BAD G RETRY "RTN","DGREGRED",90,0) Q "RTN","DGREGRED",91,0) INPUT(DGINPUT,DFN,FSTR,CNTRY) ;Let user input address changes "RTN","DGREGRED",92,0) ; Output: DGINPUT(field#)=external^internal(if any) "RTN","DGREGRED",93,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L "RTN","DGREGRED",94,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L),DGINPUT(DGN)="" Q:DGINPUT=-1 D "RTN","DGREGRED",95,0) . I $$SKIP(DGN,.DGINPUT,.FLG) Q "RTN","DGREGRED",96,0) . ; DG*5.3*1040 - Set timeout variable DGTMOT to 1, if ZIP timeout "RTN","DGREGRED",97,0) . I DGN=.1156 D ZIPINP(.DGINPUT,DFN) S:DGINPUT=-1 DGTMOT=1 Q "RTN","DGREGRED",98,0) . ; DG*5.3*1040 - Include flag DGTMOUT to track timeout with DGTMOT set to 1 "RTN","DGREGRED",99,0) . I '$$READ(DFN,DGN,.Y) S DGINPUT=-1,DGTMOT=1 Q "RTN","DGREGRED",100,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGRED",101,0) I DGINPUT'=-1 S DGINPUT(.11573)=CNTRY_"^"_$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGRED",102,0) Q "RTN","DGREGRED",103,0) GETOLD(DGCMP,DFN) ;populate array with existing address info "RTN","DGREGRED",104,0) K DGCMP "RTN","DGREGRED",105,0) N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,COUNTRY "RTN","DGREGRED",106,0) S CFORGN=0 "RTN","DGREGRED",107,0) ; get current country "RTN","DGREGRED",108,0) S CCIEN=$S(DFN:$$GET1^DIQ(2,DFN_",",.11573,"I"),1:"") "RTN","DGREGRED",109,0) S CFORGN=$$FORIEN^DGADDUTL(CCIEN) "RTN","DGREGRED",110,0) ; get current address fields and xlate to ^DIQ format "RTN","DGREGRED",111,0) S CFSTR=$$INPT1(CFORGN),CFSTR=$TR(CFSTR,",",";") "RTN","DGREGRED",112,0) ; Domestic data needs some extra fields "RTN","DGREGRED",113,0) I 'CFORGN S CFSTR=CFSTR_";.1154;.1155;.1157" "RTN","DGREGRED",114,0) I DFN D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR") "RTN","DGREGRED",115,0) F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E")) "RTN","DGREGRED",116,0) S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY" "RTN","DGREGRED",117,0) S DGCMP("OLD",.11573)=COUNTRY_"^"_CCIEN "RTN","DGREGRED",118,0) I 'CFORGN D "RTN","DGREGRED",119,0) . S DGCIEN=$G(DGCURR(2,DFN_",",.1157,"I")) "RTN","DGREGRED",120,0) . S DGST=$G(DGCURR(2,DFN_",",.1155,"I")) "RTN","DGREGRED",121,0) . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) "RTN","DGREGRED",122,0) . I DGCNTY=-1 S DGCNTY="" "RTN","DGREGRED",123,0) . S DGCMP("OLD",.1157)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3) "RTN","DGREGRED",124,0) Q "RTN","DGREGRED",125,0) ; "RTN","DGREGRED",126,0) COMPARE(DGINPUT,DGCMP) ;Display before & after address fields. "RTN","DGREGRED",127,0) N DGM,DGCNTY "RTN","DGREGRED",128,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGRED",129,0) W ! "RTN","DGREGRED",130,0) F DGM="OLD","NEW" D "RTN","DGREGRED",131,0) . I DGCMP(DGM,.11573)]"",$$FORIEN^DGADDUTL($P(DGCMP(DGM,.11573),U,2)) D DISPFGN(.DGCMP,DGM) Q "RTN","DGREGRED",132,0) . I DGM="NEW" D "RTN","DGREGRED",133,0) . . S DGCNTY=$P($G(DGCMP("NEW",.1157)),U)_" "_$P($G(DGCMP("NEW",.1157)),U,3) "RTN","DGREGRED",134,0) . . S DGCMP("NEW",.1157)=DGCNTY "RTN","DGREGRED",135,0) . . I ($L(DGCMP("NEW",.1156))>5)&($P(DGCMP("NEW",.1156),"-",2)="") S DGCMP("NEW",.1156)=$E(DGCMP("NEW",.1156),1,5)_"-"_$E(DGCMP("NEW",.1156),6,9) "RTN","DGREGRED",136,0) . D DISPUS(.DGCMP,DGM) "RTN","DGREGRED",137,0) Q "RTN","DGREGRED",138,0) ; "RTN","DGREGRED",139,0) COMPAREP(DGINPUT,DGCMP) ;Display before & after phone fields. "RTN","DGREGRED",140,0) N DGM "RTN","DGREGRED",141,0) M DGCMP("NEW")=DGINPUT "RTN","DGREGRED",142,0) W ! "RTN","DGREGRED",143,0) F DGM="OLD","NEW" D "RTN","DGREGRED",144,0) . W !,?2,"[",DGM," PHONE NUMBERS]" "RTN","DGREGRED",145,0) . W !,?6," Phone: ",?16,$P($G(DGCMP(DGM,.131)),U) "RTN","DGREGRED",146,0) . W !,?6," Office: ",?16,$P($G(DGCMP(DGM,.132)),U) "RTN","DGREGRED",147,0) . W ! "RTN","DGREGRED",148,0) Q "RTN","DGREGRED",149,0) ; "RTN","DGREGRED",150,0) DISPUS(DGCMP,DGM) ;tag to display US data "RTN","DGREGRED",151,0) N DGCNTRY "RTN","DGREGRED",152,0) W !,?2,"[",DGM," RESIDENTIAL ADDRESS]" "RTN","DGREGRED",153,0) W !?16,$P($G(DGCMP(DGM,.1151)),U) "RTN","DGREGRED",154,0) I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U) "RTN","DGREGRED",155,0) I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U) "RTN","DGREGRED",156,0) W !,?16,$P($G(DGCMP(DGM,.1154)),U) "RTN","DGREGRED",157,0) W:($P($G(DGCMP(DGM,.1154)),U)'="")!($P($G(DGCMP(DGM,.1155)),U)'="") "," "RTN","DGREGRED",158,0) W $P($G(DGCMP(DGM,.1155)),U) "RTN","DGREGRED",159,0) W " ",$G(DGCMP(DGM,.1156)) "RTN","DGREGRED",160,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2)) "RTN","DGREGRED",161,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGRED",162,0) I $P($G(DGCMP(DGM,.1157)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.1157)),U) "RTN","DGREGRED",163,0) W ! "RTN","DGREGRED",164,0) Q "RTN","DGREGRED",165,0) ; "RTN","DGREGRED",166,0) DISPFGN(DGCMP,DGM) ;tag to display Foreign data "RTN","DGREGRED",167,0) N DGCNTRY "RTN","DGREGRED",168,0) W !,?2,"[",DGM," RESIDENTIAL ADDRESS]" "RTN","DGREGRED",169,0) W !?16,$P($G(DGCMP(DGM,.1151)),U) "RTN","DGREGRED",170,0) I $P($G(DGCMP(DGM,.1152)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1152)),U) "RTN","DGREGRED",171,0) I $P($G(DGCMP(DGM,.1153)),U)'="" W !,?16,$P($G(DGCMP(DGM,.1153)),U) "RTN","DGREGRED",172,0) ;W !,?16,$P($G(DGCMP(DGM,.11572)),U)_" "_$P($G(DGCMP(DGM,.1154)),U)_" "_$P($G(DGCMP(DGM,.11571)),U) ;DG*1010 comment out "RTN","DGREGRED",173,0) W !,?16,$P($G(DGCMP(DGM,.1154)),U)_" "_$P($G(DGCMP(DGM,.11571)),U)_" "_$P($G(DGCMP(DGM,.11572)),U) ;DG*1010 - display postal code last "RTN","DGREGRED",174,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.11573)),U,2)) "RTN","DGREGRED",175,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGRED",176,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGRED",177,0) W ! "RTN","DGREGRED",178,0) Q "RTN","DGREGRED",179,0) ; "RTN","DGREGRED",180,0) CONFIRM(TYPE) ;Confirm if user wants to save the changes "RTN","DGREGRED",181,0) ; TYPE - used for the query message displayed to the user: "address" or "phone number" "RTN","DGREGRED",182,0) N DIR,X,Y,DTOUT,DUOUT,DIROUT "RTN","DGREGRED",183,0) S DIR(0)="Y" "RTN","DGREGRED",184,0) S DIR("A")="Are you sure that you want to save the "_TYPE_" changes" "RTN","DGREGRED",185,0) S DIR("?")="Please answer Y for YES or N for NO." "RTN","DGREGRED",186,0) D ^DIR "RTN","DGREGRED",187,0) ; DG*5.3*1040 - prompt timeout return -1 "RTN","DGREGRED",188,0) I $D(DTOUT) Q -1 "RTN","DGREGRED",189,0) I $G(Y)=0 Q 0 "RTN","DGREGRED",190,0) I $D(DUOUT)!$D(DIROUT) Q 0 "RTN","DGREGRED",191,0) Q 1 "RTN","DGREGRED",192,0) ; "RTN","DGREGRED",193,0) SAVE(DGINPUT,DFN,FSTR,FORGN) ;Save changes "RTN","DGREGRED",194,0) N DGN,DGER,DGM,L,DATA "RTN","DGREGRED",195,0) S DGER=0 "RTN","DGREGRED",196,0) ; need to get the country code into the DGINPUT array "RTN","DGREGRED",197,0) ; if it's a domestic address, we have to add in CITY,STATE & COUNTY "RTN","DGREGRED",198,0) S FSTR=FSTR_$S('FORGN:",.1154,.1155,.1157,.11573",1:",.11573") "RTN","DGREGRED",199,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) D "RTN","DGREGRED",200,0) . ; Phone numbers saved separately - skip over here "RTN","DGREGRED",201,0) . I (DGN=.131)!(DGN=.132) Q "RTN","DGREGRED",202,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGRED",203,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGRED",204,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGRED",205,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGRED",206,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGRED",207,0) . I $D(MSG) D "RTN","DGREGRED",208,0) .. S DGM="",DGER=1 "RTN","DGREGRED",209,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGRED",210,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGRED",211,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGRED",212,0) I $G(DGER)=0 W !,"Change saved." D "RTN","DGREGRED",213,0) . ; Set the CASS IND field "RTN","DGREGRED",214,0) . S DATA(.1159)="NC" "RTN","DGREGRED",215,0) . I $$UPD^DGENDBS(2,DFN,.DATA) "RTN","DGREGRED",216,0) ; DG*5.3*1040 - If EOP timeout, QUIT if variable DGTMOT exists "RTN","DGREGRED",217,0) D EOP Q:+$G(DGTMOT) "RTN","DGREGRED",218,0) Q "RTN","DGREGRED",219,0) ; "RTN","DGREGRED",220,0) SAVEPH(DGINPUT,DFN) ;Save phone changes "RTN","DGREGRED",221,0) N DGN,DGER,DGM,DATA "RTN","DGREGRED",222,0) S DGER=0 "RTN","DGREGRED",223,0) F DGN=.131,.132 D "RTN","DGREGRED",224,0) . N DGCODE,DGNAME,FDA,MSG "RTN","DGREGRED",225,0) . S DGCODE=$P($G(DGINPUT(DGN)),U,2) "RTN","DGREGRED",226,0) . S DGNAME=$P($G(DGINPUT(DGN)),U) "RTN","DGREGRED",227,0) . S FDA(2,DFN_",",DGN)=$S(DGCODE:DGCODE,1:DGNAME) "RTN","DGREGRED",228,0) . D FILE^DIE($S(DGCODE:"",1:"E"),"FDA","MSG") "RTN","DGREGRED",229,0) . I $D(MSG) D "RTN","DGREGRED",230,0) .. S DGM="",DGER=1 "RTN","DGREGRED",231,0) .. W !,"Please review the saved changes!!",! "RTN","DGREGRED",232,0) .. F S DGM=$O(MSG("DIERR",1,"TEXT",DGM)) Q:DGM="" D "RTN","DGREGRED",233,0) ... W $G(MSG("DIERR",1,"TEXT",DGM)) "RTN","DGREGRED",234,0) I $G(DGER)=0 W !,"Change saved." "RTN","DGREGRED",235,0) ; DG*5.3*1040 - If EOP timeout, QUIT if variable DGTMOT exists "RTN","DGREGRED",236,0) D EOP Q:+$G(DGTMOT) "RTN","DGREGRED",237,0) Q "RTN","DGREGRED",238,0) ; "RTN","DGREGRED",239,0) READ(DFN,DGN,Y) ;Read input, return success "RTN","DGREGRED",240,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIROUT,L,POP "RTN","DGREGRED",241,0) S SUCCESS=1,POP=0 "RTN","DGREGRED",242,0) F L=0:0 D Q:POP "RTN","DGREGRED",243,0) . S DIR(0)=2_","_DGN "RTN","DGREGRED",244,0) . I DFN S DA=DFN "RTN","DGREGRED",245,0) . D ^DIR "RTN","DGREGRED",246,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGRED",247,0) . I $D(DUOUT)!$D(DIROUT) D UPCT Q "RTN","DGREGRED",248,0) . S POP=1 "RTN","DGREGRED",249,0) Q SUCCESS "RTN","DGREGRED",250,0) INPT1(FORGN,PSTR) ; first address input prompts "RTN","DGREGRED",251,0) N FSTR "RTN","DGREGRED",252,0) ; PSTR is the full set of fields domestic & foreign combined "RTN","DGREGRED",253,0) ; FSTR is the set of fields depending on Country code "RTN","DGREGRED",254,0) S PSTR=".1151,.1152,.1153,.1154,.1155,.1157,.1156,.11571,.11572,.11573,.131,.132" "RTN","DGREGRED",255,0) S FSTR=".1151,.1152,.1153,.1156,.131,.132" "RTN","DGREGRED",256,0) I FORGN S FSTR=".1151,.1152,.1153,.1154,.11571,.11572,.131,.132" "RTN","DGREGRED",257,0) Q FSTR "RTN","DGREGRED",258,0) ZIPINP(DGINPUT,DFN) ; get ZIP+4 input "RTN","DGREGRED",259,0) ; This subroutine calls existing code to prompt for zip code and return corresponding city, state and county "RTN","DGREGRED",260,0) ; DFN must be the patient internal ID. "RTN","DGREGRED",261,0) ; DGINPUT - passed by reference - the array containing the resulting county, city, and state for the zipcode. "RTN","DGREGRED",262,0) N FCITY,FZIP,FSTATE,FCOUNTY,TYPE,DGR "RTN","DGREGRED",263,0) ; Set the necessary variables for the Residential Address "RTN","DGREGRED",264,0) ; The variable TYPE is used for Confidential and temporary address types. "RTN","DGREGRED",265,0) ; Here for the Residential Address we clear this variable. "RTN","DGREGRED",266,0) S FZIP=".1156",FCITY=".1154",FSTATE=".1155",FCOUNTY=".1157",TYPE="" "RTN","DGREGRED",267,0) D EN^DGREGTZL(.DGR,DFN) "RTN","DGREGRED",268,0) M DGINPUT=DGR "RTN","DGREGRED",269,0) Q "RTN","DGREGRED",270,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGRED",271,0) N SKIP "RTN","DGREGRED",272,0) S SKIP=0 "RTN","DGREGRED",273,0) I ($G(DGINPUT(.1151))="")&((DGN=.1152)!(DGN=.1153)) S SKIP=1 "RTN","DGREGRED",274,0) I ($G(DGINPUT(.1152))="")&(DGN=.1153) S SKIP=1 "RTN","DGREGRED",275,0) I ($G(FLG(1))'=1)&((DGN=.131)!(DGN=.132)) S SKIP=1 "RTN","DGREGRED",276,0) Q SKIP "RTN","DGREGRED",277,0) EOP ;End of page prompt "RTN","DGREGRED",278,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGRED",279,0) S DIR(0)="E" "RTN","DGREGRED",280,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGRED",281,0) D ^DIR "RTN","DGREGRED",282,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGRED",283,0) S:$D(DTOUT) DGTMOT=1 "RTN","DGREGRED",284,0) Q "RTN","DGREGRED",285,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGRED",286,0) W !,"EXIT NOT ALLOWED" "RTN","DGREGRED",287,0) Q "RTN","DGREGTE2") 0^11^B21247832^B21210063 "RTN","DGREGTE2",1,0) DGREGTE2 ;ALB/BAJ,TDM,BDB - Temporary & Confidential Address Support Routine; 02/27/2006 ; 22 Mar 2017 1:10 PM "RTN","DGREGTE2",2,0) ;;5.3;Registration;**688,754,851,1040**;Aug 13, 1993;Build 15 "RTN","DGREGTE2",3,0) ; "RTN","DGREGTE2",4,0) Q "RTN","DGREGTE2",5,0) ; "RTN","DGREGTE2",6,0) GETOLD(DGCMP,DFN,TYPE) ;populate array with existing address info "RTN","DGREGTE2",7,0) N CCIEN,DGCURR,CFORGN,CFSTR,L,T,DGCIEN,DGST,DGCNTY,FDESC,FNODE,FPECE,CCNTRY,COUNTRY "RTN","DGREGTE2",8,0) S CFORGN=0,FDESC=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTRY",1:"CONFIDENTIAL ADDR COUNTRY") "RTN","DGREGTE2",9,0) ; get current country "RTN","DGREGTE2",10,0) S FNODE=$S(TYPE="TEMP":.122,TYPE="CONF":.141,1:.11) "RTN","DGREGTE2",11,0) S FPECE=$S(TYPE="TEMP":3,TYPE="CONF":16,1:10) "RTN","DGREGTE2",12,0) S CCIEN=$P($G(^DPT(DFN,FNODE)),U,FPECE) "RTN","DGREGTE2",13,0) I CCIEN="" S CCNTRY=$O(^HL(779.004,"D","UNITED STATES","")) "RTN","DGREGTE2",14,0) S CFORGN=$$FORIEN^DGADDUTL(CCIEN) "RTN","DGREGTE2",15,0) ;get current address fields and xlate to ^DIQ format "RTN","DGREGTE2",16,0) S CFSTR=$$INPT1(DFN,CFORGN),CFSTR=$TR(CFSTR,",",";") "RTN","DGREGTE2",17,0) ; Domestic data needs some extra fields "RTN","DGREGTE2",18,0) ; add country field before lookup "RTN","DGREGTE2",19,0) D GETS^DIQ(2,DFN_",",CFSTR,"EI","DGCURR") "RTN","DGREGTE2",20,0) F L=1:1:$L(CFSTR,";") S T=$P(CFSTR,";",L),DGCMP("OLD",T)=$G(DGCURR(2,DFN_",",T,"E")) "RTN","DGREGTE2",21,0) S COUNTRY=$$CNTRYI^DGADDUTL(CCIEN) I COUNTRY=-1 S COUNTRY="UNKNOWN COUNTRY" "RTN","DGREGTE2",22,0) S DGCMP("OLD",FCNTRY)=COUNTRY "RTN","DGREGTE2",23,0) I 'CFORGN D "RTN","DGREGTE2",24,0) . S DGCIEN=$G(DGCURR(2,DFN_",",FCOUNTY,"I")) "RTN","DGREGTE2",25,0) . S DGST=$G(DGCURR(2,DFN_",",FSTATE,"I")) "RTN","DGREGTE2",26,0) . S DGCNTY=$$CNTY^DGREGAZL(DGST,DGCIEN) "RTN","DGREGTE2",27,0) . I DGCNTY=-1 S DGCNTY="" "RTN","DGREGTE2",28,0) . S DGCMP("OLD",FCOUNTY)="" I DGCNTY]"" S DGCMP("OLD",FCOUNTY)=$P(DGCNTY,U)_" "_$P(DGCNTY,U,3) "RTN","DGREGTE2",29,0) Q "RTN","DGREGTE2",30,0) INPT1(DFN,FORGN,PSTR) ; address input prompts "RTN","DGREGTE2",31,0) N FSTR "RTN","DGREGTE2",32,0) ; PSTR contains the full list of address fields to be modified "RTN","DGREGTE2",33,0) ; FSTR contains the field list based on country "RTN","DGREGTE2",34,0) S PSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPROV_","_FPSTAL_","_FCNTRY_","_FPHONE "RTN","DGREGTE2",35,0) ;S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FSTATE_","_FCOUNTY_","_FZIP_","_FPHONE "RTN","DGREGTE2",36,0) S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FZIP_","_FPHONE ;DG*5.3*851 "RTN","DGREGTE2",37,0) I FORGN S FSTR=FSLINE1_","_FSLINE2_","_FSLINE3_","_FCITY_","_FPROV_","_FPSTAL_","_FPHONE "RTN","DGREGTE2",38,0) Q FSTR "RTN","DGREGTE2",39,0) ; "RTN","DGREGTE2",40,0) SURE() ; Are you sure prompt "RTN","DGREGTE2",41,0) N DIR,X,Y,DUOUT,DTOUT,DIRUT "RTN","DGREGTE2",42,0) S DIR(0)="Y" "RTN","DGREGTE2",43,0) S DIR("B")="NO" "RTN","DGREGTE2",44,0) S DIR("A")=" SURE YOU WANT TO DELETE" "RTN","DGREGTE2",45,0) D ^DIR "RTN","DGREGTE2",46,0) Q Y "RTN","DGREGTE2",47,0) SKIP(DGN,DGINPUT) ; determine whether or not to skip the prompt "RTN","DGREGTE2",48,0) N SKIP,NULL "RTN","DGREGTE2",49,0) S SKIP=0 "RTN","DGREGTE2",50,0) S NULL=($G(DGINPUT(FSLINE1))="")!(($G(DGINPUT(FSLINE1))="@")) "RTN","DGREGTE2",51,0) I NULL,(DGN=FSLINE2) S SKIP=1 "RTN","DGREGTE2",52,0) S NULL=($G(DGINPUT(FSLINE2))="")!(($G(DGINPUT(FSLINE2))="@")) "RTN","DGREGTE2",53,0) I NULL,(DGN=FSLINE3) S SKIP=1 "RTN","DGREGTE2",54,0) Q SKIP "RTN","DGREGTE2",55,0) ; "RTN","DGREGTE2",56,0) INIT ; initialize variables "RTN","DGREGTE2",57,0) ; This tag reads the table at FLDDAT (below) to set relationship between "RTN","DGREGTE2",58,0) ; variables and Field numbers. "RTN","DGREGTE2",59,0) ; "RTN","DGREGTE2",60,0) ; Set up array of fields needed "RTN","DGREGTE2",61,0) N I,T,FTYPE,VNAME,FNUM,RFLD "RTN","DGREGTE2",62,0) F I=1:1 S T=$P($T(FLDDAT+I^DGREGTE2),";;",3) Q:T="QUIT" D "RTN","DGREGTE2",63,0) . S FTYPE=$P(T,";",1),VNAME=$P(T,";",2),FNUM=$P(T,";",3) "RTN","DGREGTE2",64,0) . I FTYPE=TYPE S @VNAME=FNUM "RTN","DGREGTE2",65,0) ; Set up array of field and prompting rules "RTN","DGREGTE2",66,0) K T,I "RTN","DGREGTE2",67,0) F I=1:1 S T=$P($T(FLDPRMPT+I^DGREGTE2),";;",2) Q:T="QUIT" D "RTN","DGREGTE2",68,0) . S RFLD=$P(T,";",1) I RFLD'="ALL" S RFLD=@RFLD "RTN","DGREGTE2",69,0) . S RPROC(RFLD,$P(T,";",2),$P(T,";",3))=$P(T,";",4) "RTN","DGREGTE2",70,0) Q "RTN","DGREGTE2",71,0) FLDDAT ; Table of field values STRUCTURE --> Description;;Type;Variable Name;Field Number "RTN","DGREGTE2",72,0) ;;Street Line 1;;TEMP;FSLINE1;.1211 "RTN","DGREGTE2",73,0) ;;Street Line 2;;TEMP;FSLINE2;.1212 "RTN","DGREGTE2",74,0) ;;Street Line 3;;TEMP;FSLINE3;.1213 "RTN","DGREGTE2",75,0) ;;City;;TEMP;FCITY;.1214 "RTN","DGREGTE2",76,0) ;;State;;TEMP;FSTATE;.1215 "RTN","DGREGTE2",77,0) ;;County;;TEMP;FCOUNTY;.12111 "RTN","DGREGTE2",78,0) ;;Zip;;TEMP;FZIP;.12112 "RTN","DGREGTE2",79,0) ;;Phone;;TEMP;FPHONE;.1219 "RTN","DGREGTE2",80,0) ;;Province;;TEMP;FPROV;.1221 "RTN","DGREGTE2",81,0) ;;Postal Code;;TEMP;FPSTAL;.1222 "RTN","DGREGTE2",82,0) ;;Country;;TEMP;FCNTRY;.1223 "RTN","DGREGTE2",83,0) ;;Address Node 1;;TEMP;FNODE1;.121 "RTN","DGREGTE2",84,0) ;;Address Node 2;;TEMP;FNODE2;.122 "RTN","DGREGTE2",85,0) ;;Country data piece;;TEMP;CPEICE;3 "RTN","DGREGTE2",86,0) ;;Street Line 1;;CONF;FSLINE1;.1411 "RTN","DGREGTE2",87,0) ;;Street Line 2;;CONF;FSLINE2;.1412 "RTN","DGREGTE2",88,0) ;;Street Line 3;;CONF;FSLINE3;.1413 "RTN","DGREGTE2",89,0) ;;City;;CONF;FCITY;.1414 "RTN","DGREGTE2",90,0) ;;State;;CONF;FSTATE;.1415 "RTN","DGREGTE2",91,0) ;;County;;CONF;FCOUNTY;.14111 "RTN","DGREGTE2",92,0) ;;Zip;;CONF;FZIP;.1416 "RTN","DGREGTE2",93,0) ;;Phone;;CONF;FPHONE;.1315 "RTN","DGREGTE2",94,0) ;;Province;;CONF;FPROV;.14114 "RTN","DGREGTE2",95,0) ;;Postal Code;;CONF;FPSTAL;.14115 "RTN","DGREGTE2",96,0) ;;Country;;CONF;FCNTRY;.14116 "RTN","DGREGTE2",97,0) ;;Address Node 1;;CONF;FNODE1;.141 "RTN","DGREGTE2",98,0) ;;Address Node 2;;CONF;FNODE2;.141 "RTN","DGREGTE2",99,0) ;;Country data piece;;CONF;CPEICE;16 "RTN","DGREGTE2",100,0) ;;QUIT;;QUIT "RTN","DGREGTE2",101,0) ;; "RTN","DGREGTE2",102,0) ; DG*5.3*1040; Change NULL FSLINE1 to REPEAT response code instead of REVERSE "RTN","DGREGTE2",103,0) FLDPRMPT ;Table of prompts and responses STRUCTURE --> Description;;Field;Old Value;New Value;Response Code "RTN","DGREGTE2",104,0) ;;ALL;NULL;UPCAR;REPEAT "RTN","DGREGTE2",105,0) ;;ALL;NULL;DELETE;QUES "RTN","DGREGTE2",106,0) ;;ALL;NULL;VALUE;OK "RTN","DGREGTE2",107,0) ;;ALL;VALUE;UPCAR;REPEAT "RTN","DGREGTE2",108,0) ;;ALL;VALUE;NULL;OK "RTN","DGREGTE2",109,0) ;;ALL;VALUE;VALUE;OK "RTN","DGREGTE2",110,0) ;;FSLINE1;NULL;NULL;REPEAT "RTN","DGREGTE2",111,0) ;;FSLINE2;NULL;NULL;OK "RTN","DGREGTE2",112,0) ;;FSLINE3;NULL;NULL;OK "RTN","DGREGTE2",113,0) ;;FCITY;NULL;NULL;REVERSE "RTN","DGREGTE2",114,0) ;;FSTATE;NULL;NULL;REVERSE "RTN","DGREGTE2",115,0) ;;FZIP;NULL;NULL;REVERSE "RTN","DGREGTE2",116,0) ;;FCOUNTY;NULL;NULL;REVERSE "RTN","DGREGTE2",117,0) ;;FPROV;NULL;NULL;OK "RTN","DGREGTE2",118,0) ;;FPSTAL;NULL;NULL;OK "RTN","DGREGTE2",119,0) ;;FCNTRY;NULL;NULL;REVERSE "RTN","DGREGTE2",120,0) ;;FSLINE1;VALUE;DELETE;INSTRUCT "RTN","DGREGTE2",121,0) ;;FSLINE2;VALUE;DELETE;CONFIRM "RTN","DGREGTE2",122,0) ;;FSLINE3;VALUE;DELETE;CONFIRM "RTN","DGREGTE2",123,0) ;;FCITY;VALUE;DELETE;INSTRUCT "RTN","DGREGTE2",124,0) ;;FSTATE;VALUE;DELETE;INSTRUCT "RTN","DGREGTE2",125,0) ;;FZIP;VALUE;DELETE;INSTRUCT "RTN","DGREGTE2",126,0) ;;FCOUNTY;VALUE;DELETE;INSTRUCT "RTN","DGREGTE2",127,0) ;;FPROV;VALUE;DELETE;CONFIRM "RTN","DGREGTE2",128,0) ;;FPSTAL;VALUE;DELETE;CONFIRM "RTN","DGREGTE2",129,0) ;;FCNTRY;VALUE;DELETE;REVERSE "RTN","DGREGTE2",130,0) ;;QUIT "RTN","DGREGTE2",131,0) ;; "RTN","DGREGTED") 0^8^B71965031^B65810805 "RTN","DGREGTED",1,0) DGREGTED ;ALB/BAJ,BDB,JAM - Temporary & Confidential Address Edits API ;23 May 2017 12:48 PM "RTN","DGREGTED",2,0) ;;5.3;Registration;**688,851,941,1014,1040**;Aug 13, 1993;Build 15 "RTN","DGREGTED",3,0) ; "RTN","DGREGTED",4,0) EN(DFN,TYPE,RET) ;Entry point "RTN","DGREGTED",5,0) ; This routine controls Edits to Temporary & Confidential addresses "RTN","DGREGTED",6,0) ; "RTN","DGREGTED",7,0) ; Input "RTN","DGREGTED",8,0) ; DFN = Patient DFN "RTN","DGREGTED",9,0) ; TYPE = Type of address: "TEMP" or "CONF" "RTN","DGREGTED",10,0) ; RET = Flag to signal return to first prompt "RTN","DGREGTED",11,0) ; "RTN","DGREGTED",12,0) ; Output "RTN","DGREGTED",13,0) ; RET 0 = Return to first prompt in the address edit group "RTN","DGREGTED",14,0) ; 1 = Do not return (address was saved) "RTN","DGREGTED",15,0) ; "RTN","DGREGTED",16,0) N DGINPUT,FORGN,FSTR,ICNTRY,CNTRY,PSTR,DGCMP,DGOLD,DR,DIE "RTN","DGREGTED",17,0) N FSLINE1,FSLINE2,FSLINE3,FCITY,FSTATE,FCOUNTY,FZIP,FPHONE "RTN","DGREGTED",18,0) N FPROV,FPSTAL,FCNTRY,FNODE1,FNODE2,CPEICE,OLDC,RPROC "RTN","DGREGTED",19,0) N I,X,Y "RTN","DGREGTED",20,0) I $G(DFN)="" Q "RTN","DGREGTED",21,0) ;I ($G(DFN)'?.N) Q "RTN","DGREGTED",22,0) D INIT^DGREGTE2 I $P($G(^DPT(DFN,FNODE1)),U,9)="N" Q "RTN","DGREGTED",23,0) D GETOLD^DGREGTE2(.DGCMP,DFN,TYPE) M DGOLD=DGCMP("OLD") K DGCMP "RTN","DGREGTED",24,0) S CNTRY="",ICNTRY=$P($G(^DPT(DFN,FNODE2)),"^",CPEICE) I ICNTRY="" S ICNTRY=1 ;default US if NULL "RTN","DGREGTED",25,0) ; "RTN","DGREGTED",26,0) ; DG*5.3*1014; jam; ** Start changes ** "RTN","DGREGTED",27,0) ; RETRY tag added below "RTN","DGREGTED",28,0) RETRY ; Tag for reentering the address "RTN","DGREGTED",29,0) S FORGN=$$FOREIGN^DGADDUTL(DFN,ICNTRY,2,FCNTRY,.CNTRY) I FORGN=-1 S RET=0,DGTMOT=1 Q "RTN","DGREGTED",30,0) Q:$G(CNTRY)="" "RTN","DGREGTED",31,0) S FSTR=$$INPT1^DGREGTE2(DFN,FORGN,.PSTR),DGINPUT=1 D INPUT(.DGINPUT,DFN,FSTR) "RTN","DGREGTED",32,0) I $G(DGINPUT)=-1 S RET=0 Q "RTN","DGREGTED",33,0) ; "RTN","DGREGTED",34,0) ; DG*5.3*1014; jam; For confidential address, if required fields are missing, we can't call the validation service - force user to correct the address "RTN","DGREGTED",35,0) I TYPE="CONF",DGINPUT(.1411)=""!(DGINPUT(.1414)="")!(($G(DGINPUT(.1416))="")&('FORGN)) D G RETRY "RTN","DGREGTED",36,0) . I 'FORGN W !!?3,*7,"CONFIDENTIAL ADDRESS [LINE 1], CITY, and ZIP CODE fields are required." "RTN","DGREGTED",37,0) . I FORGN W !!?3,*7,"CONFIDENTIAL ADDRESS [LINE 1] and CITY fields are required." "RTN","DGREGTED",38,0) ; DG*5.3*1014; jam; Address Validation service for confidential address only - TEMP address will skip over this "RTN","DGREGTED",39,0) I TYPE'="CONF" G SVADD "RTN","DGREGTED",40,0) ; Place the country code and name into the DGINPUT array "RTN","DGREGTED",41,0) S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,""))_"^"_CNTRY "RTN","DGREGTED",42,0) ; DG*5.3*1014; Display address entered - user may reenter the address or continue to Validation service. "RTN","DGREGTED",43,0) W ! "RTN","DGREGTED",44,0) N DGNEWADD "RTN","DGREGTED",45,0) M DGNEWADD("NEW")=DGINPUT "RTN","DGREGTED",46,0) I FORGN D DISPFGN(.DGNEWADD,"NEW") "RTN","DGREGTED",47,0) I 'FORGN D DISPUS(.DGNEWADD,"NEW") "RTN","DGREGTED",48,0) K DGNEWADD "RTN","DGREGTED",49,0) CHK ; DG*5.3*1014; Prompt user and allow them to correct the address or continue to Validation service "RTN","DGREGTED",50,0) N DIR "RTN","DGREGTED",51,0) S DIR("A",1)="If address is ready for validation enter to continue, 'E' to Edit" "RTN","DGREGTED",52,0) S DIR("A")=" or '^' to quit" "RTN","DGREGTED",53,0) S DIR(0)="FO" "RTN","DGREGTED",54,0) S DIR("?")="Enter 'E' to edit the address, to continue to address validation or '^' to exit and cancel the address entry/edit.." "RTN","DGREGTED",55,0) D ^DIR K DIR "RTN","DGREGTED",56,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout and QUIT "RTN","DGREGTED",57,0) I $D(DTOUT) S DGTMOT=1 Q "RTN","DGREGTED",58,0) ; DG*5.3*1040 - Remove the DTOUT check "RTN","DGREGTED",59,0) I $D(DUOUT) W !,"Address changes not saved." D EOP Q ;Exiting - Not saving address "RTN","DGREGTED",60,0) I X="E"!(X="e") G RETRY ; re-enter address "RTN","DGREGTED",61,0) I X'="" G CHK ; at this point, any response but will not be accepted "RTN","DGREGTED",62,0) ; DG*5.3*1014; jam; Add call to Address Validation service "RTN","DGREGTED",63,0) N DGADVRET "RTN","DGREGTED",64,0) S DGADVRET=$$EN^DGADDVAL(.DGINPUT,"C") "RTN","DGREGTED",65,0) ; DG*5.3*1040; if return is -1 timeout occurred "RTN","DGREGTED",66,0) I DGADVRET=-1 S DGTMOT=1 Q "RTN","DGREGTED",67,0) ; if return is 0 - address could not be validated "RTN","DGREGTED",68,0) I 'DGADVRET W !!,"No Results - UAM Address Validation Service is unable to validate the address.",!,"Please verify the address entered. " D EOP Q:+$G(DGTMOT) ; DG*5.3*1040 - Check EOP timeout and QUIT "RTN","DGREGTED",69,0) ; DGINPUT array contains the address that is validated/accepted or what the user entered if the validation service failed "RTN","DGREGTED",70,0) ; "RTN","DGREGTED",71,0) SVADD ; Save the address - SVADD tag added for DG*5.3*1014; jam; ** End of 1014 changes ** "RTN","DGREGTED",72,0) D SAVE(.DGINPUT,DFN,FSTR,CNTRY) "RTN","DGREGTED",73,0) Q "RTN","DGREGTED",74,0) ; "RTN","DGREGTED",75,0) INPUT(DGINPUT,DFN,FSTR) ;Let user input address changes "RTN","DGREGTED",76,0) ; Input: "RTN","DGREGTED",77,0) ; DGINPUT - Array to hold field values DGINPUT(field#) "RTN","DGREGTED",78,0) ; DFN - Patient DFN "RTN","DGREGTED",79,0) ; FSTR - String of fields (foreign or domestic) to work with "RTN","DGREGTED",80,0) ; "RTN","DGREGTED",81,0) ; Output: "RTN","DGREGTED",82,0) ; DGINPUT(field#)=external^internal(if any) "RTN","DGREGTED",83,0) ; "RTN","DGREGTED",84,0) N DIR,X,Y,DA,DGR,DTOUT,DUOUT,DIROUT,DGN,L,SUCCESS,REP "RTN","DGREGTED",85,0) F L=1:1:$L(FSTR,",") S DGN=$P(FSTR,",",L) Q:DGINPUT=-1 D "RTN","DGREGTED",86,0) . S REP=0 "RTN","DGREGTED",87,0) . I $$SKIP^DGREGTE2(DGN,.DGINPUT) Q "RTN","DGREGTED",88,0) . ; DG*5.3*1040 - Set variable DGTMOT to 1 to track ZIP timeout "RTN","DGREGTED",89,0) . I DGN=FZIP D ZIPINP(.DGINPUT,DFN) S:DGINPUT=-1 DGTMOT=1 Q ;DG*5.3*851 "RTN","DGREGTED",90,0) . S SUCCESS=$$READ(DFN,.DGOLD,DGN,.Y,.REP) I 'SUCCESS D Q "RTN","DGREGTED",91,0) . . ; DG*5.3*1040 - Set variable DGTMOT to 1 to track field timeout "RTN","DGREGTED",92,0) . . I 'REP S DGINPUT=-1,DGTMOT=1 Q "RTN","DGREGTED",93,0) . . ; repeat the question so we have to set the counter back "RTN","DGREGTED",94,0) . . S L=L-1 "RTN","DGREGTED",95,0) . ; DG*5.3*1014 ;jam; prevent the @ from getting into the array "RTN","DGREGTED",96,0) . I $G(Y)="@" S Y="" "RTN","DGREGTED",97,0) . S DGINPUT(DGN)=$G(Y) "RTN","DGREGTED",98,0) READ(DFN,DGOLD,DGN,Y,REP) ;Read input, return success "RTN","DGREGTED",99,0) ; Input: "RTN","DGREGTED",100,0) ; DFN - Patient DFN "RTN","DGREGTED",101,0) ; DGOLD - Array of current field values. "RTN","DGREGTED",102,0) ; DGN - Current field to read "RTN","DGREGTED",103,0) ; Y - Current Field value "RTN","DGREGTED",104,0) ; REP - Flag -- should prompt be repeated "RTN","DGREGTED",105,0) ; "RTN","DGREGTED",106,0) ; Output "RTN","DGREGTED",107,0) ; SUCCESS 1 = Input successful go to next prompt "RTN","DGREGTED",108,0) ; 0 = Input unsuccessful Repeat or Abort as indicated by REP variable "RTN","DGREGTED",109,0) ; REP 1 = Error - Repeat prompt "RTN","DGREGTED",110,0) ; 0 = Error - Do not repeat "RTN","DGREGTED",111,0) ; Y New field value "RTN","DGREGTED",112,0) ; "RTN","DGREGTED",113,0) N SUCCESS,DIR,DA,DTOUT,DUOUT,DIRUT,DIROUT,X,L,T,POP,DGST,CNTYFLD,REVERSE "RTN","DGREGTED",114,0) S SUCCESS=1,(POP,REVERSE)=0,CNTYFLD=$S(TYPE="TEMP":"TEMPORARY ADDRESS COUNTY",1:"CONFIDENTIAL ADDRESS COUNTY") "RTN","DGREGTED",115,0) S DIR(0)=2_","_DGN,DIR("B")=$G(DGOLD(DGN)) "RTN","DGREGTED",116,0) S DA=DFN "RTN","DGREGTED",117,0) F D Q:POP "RTN","DGREGTED",118,0) . K DTOUT,DUOUT,DIROUT "RTN","DGREGTED",119,0) . S MSG="" "RTN","DGREGTED",120,0) . I ($G(DGINPUT(FSTATE))="")&(DGN=FCOUNTY) S POP=1 Q "RTN","DGREGTED",121,0) . S DIR("B")=$S($D(DGINPUT(DGN)):DGINPUT(DGN),$G(DGOLD(DGN))]"":DGOLD(DGN),1:"") "RTN","DGREGTED",122,0) . I DGN=FCOUNTY D "RTN","DGREGTED",123,0) . . S DIR(0)="POA^DIC(5,"_$P(DGINPUT(FSTATE),U)_",1,:AEMQ" "RTN","DGREGTED",124,0) . . S DIR("A")=CNTYFLD_": " "RTN","DGREGTED",125,0) . . ; we can't prompt if there's no previous entry "RTN","DGREGTED",126,0) . . I $D(DGOLD(DGN)) S T=$L(DGOLD(DGN)," "),DIR("B")=$P($G(DGOLD(DGN))," ",1,T-1) "RTN","DGREGTED",127,0) . D ^DIR "RTN","DGREGTED",128,0) . I $D(DTOUT) S POP=1,SUCCESS=0 Q "RTN","DGREGTED",129,0) . I $D(DIRUT) S MSG="",REVERSE=0 D ANSW(X,.DGOLD,DGN,.MSG,.Y,.REP,$G(RET),.REVERSE) S:REP SUCCESS=0 W:MSG]"" !,MSG "RTN","DGREGTED",130,0) . I REVERSE S (REP,SUCCESS)=0 "RTN","DGREGTED",131,0) . S POP=1 "RTN","DGREGTED",132,0) Q SUCCESS "RTN","DGREGTED",133,0) ; "RTN","DGREGTED",134,0) SAVE(DGINPUT,DFN,FSTR,CNTRY) ;Save changes "RTN","DGREGTED",135,0) N DATA,DGENDA,L,T,FILE,ERROR,LOOP,LOOP1,LOOP2 "RTN","DGREGTED",136,0) S DGENDA=DFN,FILE=2 "RTN","DGREGTED",137,0) ; need to get the country code into the DGINPUT array "RTN","DGREGTED",138,0) S DGINPUT(FCNTRY)=$O(^HL(779.004,"B",CNTRY,"")) "RTN","DGREGTED",139,0) S FSTR=FSTR_","_FCNTRY "RTN","DGREGTED",140,0) I (TYPE="TEMP")!(TYPE="CONF") S FSTR=FSTR_","_FCITY_","_FSTATE_","_FCOUNTY ;DG*5.3*851 "RTN","DGREGTED",141,0) F L=1:1:$L(FSTR,",") S T=$P(FSTR,",",L) S DATA(T)=$P($G(DGINPUT(T)),U) "RTN","DGREGTED",142,0) ;JAM; Set the CASS field for Temp and Confidential; DG*5.3*941 "RTN","DGREGTED",143,0) I TYPE="TEMP" S DATA(.12115)="NC" "RTN","DGREGTED",144,0) I TYPE="CONF" S DATA(.14117)="NC" "RTN","DGREGTED",145,0) Q $$UPD^DGENDBS(FILE,.DGENDA,.DATA,.ERROR) "RTN","DGREGTED",146,0) ; "RTN","DGREGTED",147,0) ANSW(YIN,DGOLD,DGN,MSG,YOUT,REP,RET,REVERSE) ;analyze input commands "RTN","DGREGTED",148,0) ; This API will process reads and set bits, messages and flags accordingly. "RTN","DGREGTED",149,0) ; Because there is different behavior depending on prompt and input, the input "RTN","DGREGTED",150,0) ; of each field needs to be evaluated separately at the time of input and before "RTN","DGREGTED",151,0) ; deciding to continue the edit. Input rules are loaded into array RPROC at the "RTN","DGREGTED",152,0) ; beginning of this routine in call to INIT^DGREGTE2. "RTN","DGREGTED",153,0) ; "RTN","DGREGTED",154,0) ; Input "RTN","DGREGTED",155,0) ; N - User input "Y" value "RTN","DGREGTED",156,0) ; DGOLD - Array of current values "RTN","DGREGTED",157,0) ; DGN - Current field "RTN","DGREGTED",158,0) ; MSG - Variable for Text message "RTN","DGREGTED",159,0) ; YOUT - User input ("Y") value "RTN","DGREGTED",160,0) ; REP - Flag to repeat prompt "RTN","DGREGTED",161,0) ; RET - Flag to return success or failure to calling module "RTN","DGREGTED",162,0) ; REVERSE - Flag to revert to first prompt in sequence "RTN","DGREGTED",163,0) ; "RTN","DGREGTED",164,0) ; Output "RTN","DGREGTED",165,0) ; MSG - Text message (for incorrect entries) "RTN","DGREGTED",166,0) ; REP - Repeat current prompt "RTN","DGREGTED",167,0) ; REVERSE - Revert to first prompt in sequence "RTN","DGREGTED",168,0) ; "RTN","DGREGTED",169,0) N X,Y,DTOUT,DIRUT,DUOUT,PRMPT,RMSG,TDGN,ACT "RTN","DGREGTED",170,0) N OLDVAL,NEWVAL "RTN","DGREGTED",171,0) ; "RTN","DGREGTED",172,0) S PRMPT=$S(TYPE="TEMP":"TEMPORARY",1:"CONFIDENTIAL") "RTN","DGREGTED",173,0) S RMSG("LINE")="BUT I NEED AT LEAST ONE LINE OF A "_PRMPT_" ADDRESS" "RTN","DGREGTED",174,0) S RMSG("REVERSE")="This is a required response." "RTN","DGREGTED",175,0) S RMSG("REPEAT")="EXIT NOT ALLOWED ??" "RTN","DGREGTED",176,0) S RMSG("QUES")="??" "RTN","DGREGTED",177,0) S RMSG("INSTRUCT")=$S(TYPE="TEMP":"TADD^DGLOCK1",TYPE="CONF":"CADD1^DGLOCK3",1:"OK") "RTN","DGREGTED",178,0) S OLDVAL=$G(DGOLD(DGN)),OLDVAL=$$PROC(OLDVAL),NEWVAL=$$PROC(YIN) "RTN","DGREGTED",179,0) S TDGN=$S($D(RPROC(DGN,OLDVAL,NEWVAL)):DGN,1:"ALL") "RTN","DGREGTED",180,0) I '$D(RPROC(TDGN,OLDVAL,NEWVAL)) S RPROC(TDGN,OLDVAL,NEWVAL)="OK" "RTN","DGREGTED",181,0) S ACT=RPROC(TDGN,OLDVAL,NEWVAL) "RTN","DGREGTED",182,0) D @ACT "RTN","DGREGTED",183,0) Q "RTN","DGREGTED",184,0) REVERSE ; "RTN","DGREGTED",185,0) ; DG*5.3*1040; LINE message for NULL "FSLINE1" is moved to REPEAT "RTN","DGREGTED",186,0) ;N MSUB "RTN","DGREGTED",187,0) ;S MSUB=$S(DGN=FSLINE1:"LINE",1:"REVERSE") "RTN","DGREGTED",188,0) ;W !,RMSG(MSUB) "RTN","DGREGTED",189,0) W !,RMSG("REVERSE") "RTN","DGREGTED",190,0) S REVERSE=1 "RTN","DGREGTED",191,0) Q "RTN","DGREGTED",192,0) REPEAT ; "RTN","DGREGTED",193,0) ;W !,RMSG("REPEAT") "RTN","DGREGTED",194,0) N MSUB "RTN","DGREGTED",195,0) S MSUB=$S(DGN=FSLINE1:"LINE",1:"REPEAT") "RTN","DGREGTED",196,0) W !,RMSG(MSUB) "RTN","DGREGTED",197,0) S REP=1 "RTN","DGREGTED",198,0) Q "RTN","DGREGTED",199,0) OK ; "RTN","DGREGTED",200,0) Q "RTN","DGREGTED",201,0) QUES ; "RTN","DGREGTED",202,0) W RMSG("QUES") "RTN","DGREGTED",203,0) S REP=1 "RTN","DGREGTED",204,0) Q "RTN","DGREGTED",205,0) CONFIRM ; "RTN","DGREGTED",206,0) I '$$SURE^DGREGTE2 S YOUT=DGOLD(DGN),REP=1 Q "RTN","DGREGTED",207,0) S YOUT=YIN,REP=0 "RTN","DGREGTED",208,0) Q "RTN","DGREGTED",209,0) INSTRUCT ; "RTN","DGREGTED",210,0) D @RMSG("INSTRUCT") "RTN","DGREGTED",211,0) S REP=1 "RTN","DGREGTED",212,0) Q "RTN","DGREGTED",213,0) PROC(VAL) ;process the input and return a type of value "RTN","DGREGTED",214,0) ; input "RTN","DGREGTED",215,0) ; VAL - The value to examine "RTN","DGREGTED",216,0) ; "RTN","DGREGTED",217,0) ; output "RTN","DGREGTED",218,0) ; a value type "RTN","DGREGTED",219,0) ; VALUE = input - validation is a separate task and is not done here "RTN","DGREGTED",220,0) ; NULL = NULL input "RTN","DGREGTED",221,0) ; UPCAR = the "^" character "RTN","DGREGTED",222,0) ; DELETE = the "@" character "RTN","DGREGTED",223,0) Q $S(VAL="":"NULL",$E(VAL)="^":"UPCAR",$E(VAL)="@":"DELETE",1:"VALUE") "RTN","DGREGTED",224,0) EOP ;End of page prompt "RTN","DGREGTED",225,0) N DIR,DTOUT,DUOUT,DIROUT,X,Y "RTN","DGREGTED",226,0) S DIR(0)="E" "RTN","DGREGTED",227,0) S DIR("A")="Press ENTER to continue" "RTN","DGREGTED",228,0) D ^DIR "RTN","DGREGTED",229,0) ; DG*5.3*1040 - Set variable DGTMOT=1, if timeout "RTN","DGREGTED",230,0) S:$D(DTOUT) DGTMOT=1 "RTN","DGREGTED",231,0) Q "RTN","DGREGTED",232,0) ; DG*5.3*851 "RTN","DGREGTED",233,0) ZIPINP(DGINPUT,DFN) ;get ZIP+4 input "RTN","DGREGTED",234,0) N DGR,DGX "RTN","DGREGTED",235,0) D EN^DGREGTZL(.DGR,DFN) "RTN","DGREGTED",236,0) ;DG*5.3*1014 - Zip entry failed (due to timeout, or ^ entry, or input error) - before the Quit, set DGINPUT=-1 "RTN","DGREGTED",237,0) ;I $G(DGR)=-1 Q "RTN","DGREGTED",238,0) I $G(DGR)=-1 S DGINPUT=-1 Q "RTN","DGREGTED",239,0) M DGINPUT=DGR "RTN","DGREGTED",240,0) S DGX=DGINPUT(FCOUNTY),DGINPUT(FCOUNTY)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGREGTED",241,0) S DGX=DGINPUT(FSTATE),DGINPUT(FSTATE)=$P(DGX,"^",2)_"^"_$P(DGX,"^",1) "RTN","DGREGTED",242,0) Q "RTN","DGREGTED",243,0) SKIP(DGN,DGINPUT,FLG) ; determine whether or not to skip this step "RTN","DGREGTED",244,0) N SKIP "RTN","DGREGTED",245,0) S SKIP=0 "RTN","DGREGTED",246,0) I ($G(DGINPUT(FSLINE1))="")&((DGN=FSLINE2)!(DGN=FSLINE3)) S SKIP=1 "RTN","DGREGTED",247,0) I ($G(DGINPUT(FSLINE2))="")&(DGN=FSLINE3) S SKIP=1 "RTN","DGREGTED",248,0) I ($G(FLG(1))'=1)&((DGN=FPHONE)) S SKIP=1 "RTN","DGREGTED",249,0) Q SKIP "RTN","DGREGTED",250,0) UPCT ;Indicate "^" or "^^" are unacceptable inputs. "RTN","DGREGTED",251,0) W !,"EXIT NOT ALLOWED ??" "RTN","DGREGTED",252,0) Q "RTN","DGREGTED",253,0) ; "RTN","DGREGTED",254,0) ; DG*5.3*1014;jam; Added these tags to display the address prior to calling the Validation service "RTN","DGREGTED",255,0) DISPUS(DGCMP,DGM) ;tag to display US data "RTN","DGREGTED",256,0) N DGCNTRY "RTN","DGREGTED",257,0) ; "AddressLine1,AddressLine2,AddressLine3,City,State,County,Zip,Province,PostalCode^Country" "RTN","DGREGTED",258,0) ; ".1411,.1412,.1413,.1414,.1415,.14111,.1416,.14114,.14115,.14116" ; Confidential address fields "RTN","DGREGTED",259,0) W !,?2,"[",DGM," CONFIDENTIAL ADDRESS]" "RTN","DGREGTED",260,0) W !?16,$G(DGCMP(DGM,.1411)) "RTN","DGREGTED",261,0) I $G(DGCMP(DGM,.1412))'="" W !,?16,$G(DGCMP(DGM,.1412)) "RTN","DGREGTED",262,0) I $G(DGCMP(DGM,.1413))'="" W !,?16,$G(DGCMP(DGM,.1413)) "RTN","DGREGTED",263,0) W !,?16,$G(DGCMP(DGM,.1414)) "RTN","DGREGTED",264,0) W:($G(DGCMP(DGM,.1414))'="")!($P($G(DGCMP(DGM,.1415)),U,2)'="") "," "RTN","DGREGTED",265,0) W $P($G(DGCMP(DGM,.1415)),U,2) "RTN","DGREGTED",266,0) W " ",$G(DGCMP(DGM,.1416)) "RTN","DGREGTED",267,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.14116)),U)) "RTN","DGREGTED",268,0) I DGCNTRY]"",(DGCNTRY'=-1) W !?16,DGCNTRY "RTN","DGREGTED",269,0) I $P($G(DGCMP(DGM,.14111)),U)'="" W !,?6," County: ",$P($G(DGCMP(DGM,.14111)),U,2) "RTN","DGREGTED",270,0) W ! "RTN","DGREGTED",271,0) Q "RTN","DGREGTED",272,0) ; "RTN","DGREGTED",273,0) DISPFGN(DGCMP,DGM) ;tag to display Foreign data "RTN","DGREGTED",274,0) N DGCNTRY "RTN","DGREGTED",275,0) W !,?2,"[",DGM," CONFIDENTIAL ADDRESS]" "RTN","DGREGTED",276,0) W !?16,$G(DGCMP(DGM,.1411)) "RTN","DGREGTED",277,0) I $G(DGCMP(DGM,.1412))'="" W !,?16,$G(DGCMP(DGM,.1412)) "RTN","DGREGTED",278,0) I $G(DGCMP(DGM,.1413))'="" W !,?16,$G(DGCMP(DGM,.1413)) "RTN","DGREGTED",279,0) W !,?16,$G(DGCMP(DGM,.1414))_" "_$G(DGCMP(DGM,.14114))_" "_$G(DGCMP(DGM,.14115)) "RTN","DGREGTED",280,0) S DGCNTRY=$$CNTRYI^DGADDUTL($P($G(DGCMP(DGM,.14116)),U)) "RTN","DGREGTED",281,0) S DGCNTRY=$S(DGCNTRY="":"UNSPECIFIED COUNTRY",DGCNTRY=-1:"UNKNOWN COUNTRY",1:DGCNTRY) "RTN","DGREGTED",282,0) I DGCNTRY]"" W !?16,DGCNTRY "RTN","DGREGTED",283,0) W ! "RTN","DGREGTED",284,0) Q "RTN","DGRP") 0^3^B2606972^B2492413 "RTN","DGRP",1,0) DGRP ;ALB/MRL - REGISTRATION ENTRY POINT ;06 JUN 88@2300 "RTN","DGRP",2,0) ;;5.3;Registration;**108,114,250,1040**;Aug 13, 1993;Build 15 "RTN","DGRP",3,0) ; "RTN","DGRP",4,0) EN W ! S DIC="^DPT(",DIC(0)="AEQMZ" S:$S(('$D(DGRPV)#2):0,DGRPV:0,1:1) DIC(0)=DIC(0)_"L" D ^DIC "RTN","DGRP",5,0) I +Y'>0 D QQ^DGRPP Q "RTN","DGRP",6,0) K DIRUT,DUOUT,DTOUT "RTN","DGRP",7,0) S DFN=+Y I $P(Y,"^",3) D NEW "RTN","DGRP",8,0) K DA,DIC "RTN","DGRP",9,0) Q "RTN","DGRP",10,0) ; "RTN","DGRP",11,0) ; The following tags are used by external packages. Input DFN as "RTN","DGRP",12,0) ; IEN of PATIENT file. Consistency checker is automatically called. "RTN","DGRP",13,0) ; Screen edit allowed if DGRPV=0 "RTN","DGRP",14,0) ; "RTN","DGRP",15,0) ENED S DGRPV=0 "RTN","DGRP",16,0) EN1 I $G(DGRPV)=0 L +^DPT(DFN):3 E D MSG Q "RTN","DGRP",17,0) D ^DGRPV "RTN","DGRP",18,0) I $G(DGRPV)=0 L -^DPT(DFN) "RTN","DGRP",19,0) EN2 I $G(DGRPV)=0 L +^DPT(DFN):3 E D MSG Q "RTN","DGRP",20,0) D ^DGRP1 "RTN","DGRP",21,0) ; DG*5.3*1040 - Display MT info, if no timeout "RTN","DGRP",22,0) I '+$G(DGRPOUT) D DISPMAS^DGMTCOU1(DFN) ;DIPLAY MT FILE CP STATUS "RTN","DGRP",23,0) I $G(DGRPV)=0 L -^DPT(DFN) "RTN","DGRP",24,0) Q "RTN","DGRP",25,0) ; "RTN","DGRP",26,0) VIEW S DGRPV=1 D EN Q:$S(('$D(Y)#2):1,Y'>0:1,1:0) D EN1 G VIEW "RTN","DGRP",27,0) ELV S DGRPV=1,DGELVER=1 D EN Q:$S(('$D(Y)#2):1,Y'>0:1,1:0) D G ELV "RTN","DGRP",28,0) . L +^DPT(DFN):3 E D MSG Q "RTN","DGRP",29,0) . D ENED "RTN","DGRP",30,0) . L -^DPT(DFN) "RTN","DGRP",31,0) ELVD Q:'$D(DFN)#2 S DGELVER=1,DGRPV=0 D EN1 Q "RTN","DGRP",32,0) ; "RTN","DGRP",33,0) NEW ;if new patient xecute new patient dr string (from patient type) "RTN","DGRP",34,0) ;called from DG10, DGPMV, DGRPTU and DGREG "RTN","DGRP",35,0) ; "RTN","DGRP",36,0) ;use DGRPX as scratch variable "RTN","DGRP",37,0) I $D(^DPT(DFN,"TYPE")),$D(^DG(391,+^("TYPE"),"DR")),^("DR")]"" X ^("DR") S DIE="^DPT(",DA=DFN D ^DIE "RTN","DGRP",38,0) K DGRPX Q "RTN","DGRP",39,0) ; "RTN","DGRP",40,0) MSG ;If lock fails: "RTN","DGRP",41,0) W *7,!!,"Patient is being edited. Try again later." "RTN","DGRP",42,0) Q "RTN","DGRP",43,0) ; "RTN","DGRP",44,0) ; "RTN","DGRP",45,0) RTNS ;The following is the numbering scheme for the DGRP routines "RTN","DGRP",46,0) ; "RTN","DGRP",47,0) ; DGRP : routine driver for registration screens "RTN","DGRP",48,0) ; DGRP_n : routine for screen n where 1<=n<=15 "RTN","DGRP",49,0) ; DGRPE* : screen edit routines where line tag xy contains the "RTN","DGRP",50,0) ; DR string to edit. x = screen number, y = edit item "RTN","DGRP",51,0) ; DGRPH : help processor to display editable screens/data elements "RTN","DGRP",52,0) ; DGRPP : screen processor (controls display of high intensity, etc) "RTN","DGRP",53,0) ; DGRPU : utility routine (contains screen header, etc.) "RTN","DGRP",54,0) ; DGRPV : defines variables necessary for registration screens "RTN","DGRP",55,0) ; "RTN","DGRP",56,0) ; DGRPC* : consistency checker "RTN","DGRP",57,0) ; DGRPD* : data displays (pt inquiries) "RTN","DGRP",58,0) ; "RTN","DGRP",59,0) ;Variables set: "RTN","DGRP",60,0) ; "RTN","DGRP",61,0) ; DGRPV : 0 allows edit of data ; 1 for view "RTN","DGRP",62,0) ; DGELVER : 1 if eligibility verification ; '$D otherwise "RTN","DGRP",63,0) ; "RTN","DGRP",64,0) ; "RTN","DGRP",65,0) ; "RTN","DGRP",66,0) FILE ; The following are the numbering schemes for fields in the "RTN","DGRP",67,0) ; TYPE OF PATIENT file "RTN","DGRP",68,0) ; "RTN","DGRP",69,0) ; Fields 1-15 will be a set of codes denoting whether or not a certain "RTN","DGRP",70,0) ; screen is on or off for that type of patient. Only certain "RTN","DGRP",71,0) ; screens can be turned off, so not all field numbers will be "RTN","DGRP",72,0) ; taken. "RTN","DGRP",73,0) ; "RTN","DGRP",74,0) ; Data from these fields can be found on node S in the same "RTN","DGRP",75,0) ; piece position as the field number. "RTN","DGRP",76,0) ; "RTN","DGRP",77,0) ; Fields 11-149 will be a set of codes denoting whether a certain data "RTN","DGRP",78,0) ; element is on or off for editing. The field number is equal "RTN","DGRP",79,0) ; to SCREEN #_ITEM #. "RTN","DGRP",80,0) ; "RTN","DGRP",81,0) ; Items in these field numbers are on the E node in the same "RTN","DGRP",82,0) ; piece position as the field number. "RTN","DGRP",83,0) ; "RTN","DGRP",84,0) ; note: because fileman does not take more than 100 pieces on "RTN","DGRP",85,0) ; a node, items on screen 10 or higher were put on node "RTN","DGRP",86,0) ; E10 on piece SCREEN#_ITEM#-100. "RTN","DGRP",87,0) ; "RTN","DGRP",88,0) Q "RTN","DGRPE") 0^4^B108399788^B104572440 "RTN","DGRPE",1,0) DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC,JAM,JAM,JAM,LEG - REGISTRATIONS EDITS ;23 May 2017 1:51 PM "RTN","DGRPE",2,0) ;;5.3;Registration;**32,114,139,169,175,247,190,343,397,342,454,415,489,506,244,547,522,528,555,508,451,626,638,624,677,672,702,689,735,688,797,842,865,871,887,941,985,997,1014,1040**;Aug 13, 1993;Build 15 "RTN","DGRPE",3,0) ; "RTN","DGRPE",4,0) ;DGDR contains a string of edits; edit=screen*10+item # "RTN","DGRPE",5,0) ; "RTN","DGRPE",6,0) ;line tag screen*10+item*1000 = continuation line "RTN","DGRPE",7,0) ; "RTN","DGRPE",8,0) I DGRPS=1,DGDR["101," D CEDITS^DGRPECE(DFN) "RTN","DGRPE",9,0) I DGRPS=8 D ^DGRPEIS,Q Q ; family demographic edit...not conventional!! :) "RTN","DGRPE",10,0) I DGRPS=9 D EDIT9^DGRPEIS2,Q Q ; income screening data ($$$) "RTN","DGRPE",11,0) I DGRPS=5,DGDR["501," D "RTN","DGRPE",12,0) .I $G(DGPRFLG) D PREG^IBCNBME(DFN) Q "RTN","DGRPE",13,0) .D REG^IBCNBME(DFN) "RTN","DGRPE",14,0) .Q "RTN","DGRPE",15,0) N QUIT S QUIT=0 "RTN","DGRPE",16,0) I DGRPS=6,$S(DGDR["601,"!(DGDR["602,")!(DGDR["603,"):1,1:0) D I QUIT D Q Q ;Screen 6 subscreens "RTN","DGRPE",17,0) .;Use new ListMan screen for Military Service Episodes (DG*5.3*797) "RTN","DGRPE",18,0) . I DGDR["601," D EN^DGRP61(DFN) ; MSEs "RTN","DGRPE",19,0) . ; D SETDR("601,",.DR) "RTN","DGRPE",20,0) . ; S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",21,0) . ; D ^DIE I $D(Y) S QUIT=1 "RTN","DGRPE",22,0) . ; S DGDR=$P(DGDR,"601,",1)_$P(DGDR,"601,",2,999) "RTN","DGRPE",23,0) . I DGDR["602," D EN^DGRP6CL(DFN,.QUIT) Q:QUIT ; Conflicts "RTN","DGRPE",24,0) . I DGDR["603," D EN^DGRP6EF(DFN,.QUIT) Q:QUIT ; Exposures "RTN","DGRPE",25,0) I DGRPS=7,(DGDR["702,") D EN^DGRP7CP(DFN,.QUIT) I QUIT D Q Q ;DG*5.3*842 screen 7 cp subscreen "RTN","DGRPE",26,0) I DGRPS=11,(DGDR["1105,") D EN^DGR111(DFN) ;DG*5.3*871 screen 11 HBP subscreen "RTN","DGRPE",27,0) ; DG*5.3*997; jam; Screen 11.5 Caregiver subscreen "RTN","DGRPE",28,0) I DGRPS=11.5,(DGDR["1151,") D EN^DGRP11B(DFN) "RTN","DGRPE",29,0) I DGRPS=11.5,(DGDR["1152,") D EN^DGRP1152A(DFN) ;LEG; DG*5.3*1014 ; for CCP screen <11.5.2> "RTN","DGRPE",30,0) ;-- Tricare screen #15 "RTN","DGRPE",31,0) I DGRPS=15 D EDIT^DGRP15,Q Q "RTN","DGRPE",32,0) ; "RTN","DGRPE",33,0) N DGPH,DGPHFLG "RTN","DGRPE",34,0) K DR S (DA,Y)=DFN,DIE="^DPT(",DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",35,0) G ^DGRPE1:DGRPS>6 "RTN","DGRPE",36,0) I DGRPS=4 D ^DGRPE4 "RTN","DGRPE",37,0) D SETDR(DGDR,.DR) "RTN","DGRPE",38,0) S (DA,Y)=DFN,DIE="^DPT(" "RTN","DGRPE",39,0) D ^DIE "RTN","DGRPE",40,0) ; DG*5.3*1040 - Check for timeout in Screen 1.1 "RTN","DGRPE",41,0) I DGRPS=1.1,$D(DTOUT),'+$G(DGTMOT) S DGTMOT=1 "RTN","DGRPE",42,0) ;check for Combat Vet status "RTN","DGRPE",43,0) I $G(DGCVFLG)=1,($P($$CVEDT^DGCV(DFN),U,2)']"") D "RTN","DGRPE",44,0) . W !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!" "RTN","DGRPE",45,0) . S DIR(0)="EA" D ^DIR K DIR "RTN","DGRPE",46,0) I $G(DGPHFLG)>0 D EDITPH1^DGRPLE() "RTN","DGRPE",47,0) Q K DA,DIE,DR,DGCT,DGCVFLG,DGDR,DGDRD,DGDRS,DGRPADI,I,J,J1,DGCOMLOC,DIPA "RTN","DGRPE",48,0) Q "RTN","DGRPE",49,0) ; "RTN","DGRPE",50,0) SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected "RTN","DGRPE",51,0) N DGCT,DGDRS,J1,J2 "RTN","DGRPE",52,0) K DR S DR="",DGDRS="DR",DGCT=0 "RTN","DGRPE",53,0) F I=1:1 S J=$P(DGDR,",",I) Q:J="" S J1=J D:$T(@J1) "RTN","DGRPE",54,0) . S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",55,0) . N J2 "RTN","DGRPE",56,0) . F J2=0:1 S J1=J*1000+J2 Q:'$T(@J1) S DGDRD=$P($T(@J1),";;",2) D S "RTN","DGRPE",57,0) Q "RTN","DGRPE",58,0) ; "RTN","DGRPE",59,0) S I $L(@DGDRS)+$L(DGDRD)<241 S @DGDRS=@DGDRS_DGDRD Q "RTN","DGRPE",60,0) S DGCT=DGCT+1,DGDRS="DR(1,2,"_DGCT_")",@DGDRS=DGDRD Q "RTN","DGRPE",61,0) Q "RTN","DGRPE",62,0) ; "RTN","DGRPE",63,0) SETFLDS(DGDR) ; Set up fields to edit "RTN","DGRPE",64,0) Q "RTN","DGRPE",65,0) ; "RTN","DGRPE",66,0) ;DG*5.3*941 - JAM - Reg Screens 1 and 1.1 new formats - Lines below updated for new field locations "RTN","DGRPE",67,0) 101 ;; "RTN","DGRPE",68,0) 102 ;;1; "RTN","DGRPE",69,0) 103 ;;.091; "RTN","DGRPE",70,0) 104 ;;.134;.135;@21;S X=$$YN1316^DGRPE(DFN);S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW; "RTN","DGRPE",71,0) 105 ;;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE; "RTN","DGRPE",72,0) ;DG*5.3*985; JAM - Group 6 added to screen 1 - Preferred Name "RTN","DGRPE",73,0) 106 ;;.2405; "RTN","DGRPE",74,0) ;JAM; DG*5.3*941 - Tag 108 added for QUES^DGRPU1 (ICR 413) to edit the perm address with the home/office phone numbers since patch 941 removed these fields from the Perm Address edit logic "RTN","DGRPE",75,0) 108 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG); "RTN","DGRPE",76,0) 109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^"); "RTN","DGRPE",77,0) ; DG*5.3*1040 - If no timeout from previous field then proceed to next prompt "RTN","DGRPE",78,0) 111 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGRED(DFN,.FLG);D:'+$G(DGTMOT) RESMVQ^DGREGCP1(DFN); "RTN","DGRPE",79,0) ;JAM, DG*5.3*941, Home and Office phone numbers not associated with Perm Address - set flg(1)=0 so we don't edit phone numbers with permanent address "RTN","DGRPE",80,0) ;CLT, Copy Permanent Mailing Address to Residential Address ;DG*5.3*941 "RTN","DGRPE",81,0) ; If Perm address is not null, go to update of address. Otherwise give user option to copy residential address to perm. "RTN","DGRPE",82,0) ; and if address is copied quit, otherwise continue with entering in a perm address. "RTN","DGRPE",83,0) 112 ;;S:$G(^DPT(DFN,.11))'="" Y="@30";D DR11^DGRPE S:$G(^DPT(DFN,.11))'="" Y="@31"; "RTN","DGRPE",84,0) ; DG*5.3*1040 - If no timeout from previous field then proceed to next prompt "RTN","DGRPE",85,0) 112000 ;;@30;N FLG S FLG(1)=0,FLG(2)=1 D EN^DGREGAED(DFN,.FLG) D:'+$G(DGTMOT) PERMMVQ^DGREGCP1(DFN);@31; "RTN","DGRPE",86,0) 113 ;;.12105TEMP MAILING ADDRESS ACTIVE;S:X="N" Y="@15";S DIE("NO^")="";.1217TEMP MAILING ADDRESS START DATE;.1218TEMP MAILING ADDRESS END DATE;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET&('+$G(DGTMOT)) Y=.12105;@15;K DIE("NO^"); "RTN","DGRPE",87,0) 114 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105; "RTN","DGRPE",88,0) ; DG*5.3*1014;jam; add K ^DIE("NO^") after enty of confidential address so if we loop back to beginning, we can exit "RTN","DGRPE",89,0) ; DG*5.3*1040 - Add check for variable DGTMOT "RTN","DGRPE",90,0) 114000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) K DIE("NO^") S:'RET&('+$G(DGTMOT)) Y=.14105;@111;K DIE("NO^"); "RTN","DGRPE",91,0) 201 ;;.05;.08;.092;.093;.2401:.2403;57.4//NOT APPLICABLE; "RTN","DGRPE",92,0) 202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^"); "RTN","DGRPE",93,0) 203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06); "RTN","DGRPE",94,0) 205 ;;.181; "RTN","DGRPE",95,0) ; patch DG*5.3*985 - NOK - Tags 301 and 302 for Primary and Secondary NOK: phone number no longer copied when copying patient address - phone number entered on its own "RTN","DGRPE",96,0) ; patch DG*5.3*997; jam; Tags 301-305 modified to allow for copy or entry of Country/foreign addresses "RTN","DGRPE",97,0) ;301 ;;.211;S:X']"" Y="@31";.212;D DR301^DGRPE S:DG4=1 Y=.213;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y="@30";.213;K DG4;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215:.217;.2207;@30;.219;.21011;@31; "RTN","DGRPE",98,0) ; "RTN","DGRPE",99,0) 301 ;;.211;S:X']"" Y="@31";.212;.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y="@30";.221//USA;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215;.216;S DGADD=".21" D DR301^DGRPE S:DG4=1 Y=.222;.217;.2207;S Y="@30";.222;.223;@30;K DG4;.219;.21011;@31; "RTN","DGRPE",100,0) ;302 ;;.2191;S:X']"" Y="@32";.2192;D DR301^DGRPE S:DG4=1 Y=.2193;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y="@30"; "RTN","DGRPE",101,0) ;302000 ;;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195:.2197;.2203;@30;.2199;.211011;@32; "RTN","DGRPE",102,0) 302 ;;.2191;S:X']"" Y="@32";.2192;.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y="@301"; "RTN","DGRPE",103,0) 302000 ;;.2101//USA;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195;.2196;S DGADD=".211" D DR301^DGRPE S:DG4=1 Y=.2102;.2197;.2203;S Y="@301";.2102;.2103;@301;K DG4;.2199;.211011;@32; "RTN","DGRPE",104,0) ; "RTN","DGRPE",105,0) 303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";.332;@34; "RTN","DGRPE",106,0) ;303000 ;;S:$G(DGX1) Y="@341";.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335:.337;.2201;.339;.33011;S DGX1=2;@341; "RTN","DGRPE",107,0) ;303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);@35; "RTN","DGRPE",108,0) ;303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2; "RTN","DGRPE",109,0) ; "RTN","DGRPE",110,0) 303000 ;;S:$G(DGX1) Y="@341";.3306//USA;.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335;.336; S DGADD=".33" D DR301^DGRPE S:DG4=1 Y=.3307;.337;.2201;S Y="@361";.3307;.3308;@361;K DG4;.339;.33011;S DGX1=2;@341; "RTN","DGRPE",111,0) 303001 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);.3306///^S X=$P(DGX2,U,12);.3307///^S X=$P(DGX2,U,13);.3308///^S X=$P(DGX2,U,14);@35; "RTN","DGRPE",112,0) 303002 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);@351;K DGX1,DGX2; "RTN","DGRPE",113,0) ; "RTN","DGRPE",114,0) ;304 ;;.3311;S:X']"" Y="@36";.3312;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315:.3317;.2204;.3319;.331011;@36; "RTN","DGRPE",115,0) 304 ;;.3311;S:X']"" Y="@36";.3312;.331012//USA;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315;.3316; S DGADD=".331" D DR301^DGRPE S:DG4=1 Y=.331013;.3317;.2204;S Y="@37";.331013;.331014;@37;K DG4;.3319;.331011;@36; "RTN","DGRPE",116,0) ; "RTN","DGRPE",117,0) 305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@372";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@372;.341;S:X']"" DGX1=2,Y="@371";.342;@371; "RTN","DGRPE",118,0) ;305000 ;;S:$G(DGX1) Y="@38";.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345:.347;.2202;.349;.34011;S DGX1=2;@38; "RTN","DGRPE",119,0) ;305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);@381 "RTN","DGRPE",120,0) ;305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2; "RTN","DGRPE",121,0) 305000 ;;S:$G(DGX1) Y="@38";.34012//USA;.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345;.346; S DGADD=".34" D DR301^DGRPE S:DG4=1 Y=.34013;.347;.2202;S Y="@391";.34013;.34014;@391;K DG4;.349;.34011;S DGX1=2;@38; "RTN","DGRPE",122,0) 305001 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);.34012///^S X=$P(DGX2,U,12);.34013///^S X=$P(DGX2,U,13);.34014///^S X=$P(DGX2,U,14);@381 "RTN","DGRPE",123,0) 305002 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);@39;K DGX1,DGX2; "RTN","DGRPE",124,0) ; "RTN","DGRPE",125,0) 401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41; "RTN","DGRPE",126,0) 402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42; "RTN","DGRPE",127,0) 501 ;; "RTN","DGRPE",128,0) 502 ;;.381;.382///NOW; "RTN","DGRPE",129,0) 503 ;;.383; "RTN","DGRPE",130,0) 601 ;;Q; "RTN","DGRPE",131,0) 602 ;;Q; "RTN","DGRPE",132,0) 603 ;;Q; "RTN","DGRPE",133,0) 604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62; "RTN","DGRPE",134,0) 605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63; "RTN","DGRPE",135,0) 606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132; "RTN","DGRPE",136,0) 607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614; "RTN","DGRPE",137,0) 608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162; "RTN","DGRPE",138,0) AD ; DG*5.3*1014;jam; Replace code below - store data via Fileman and not direct global sets "RTN","DGRPE",139,0) ; Input: DGADD =.21 for copying to NOK "RTN","DGRPE",140,0) ; =.211 for copying to NOK2 "RTN","DGRPE",141,0) ; "RTN","DGRPE",142,0) ;N DGZ4,DGPC "RTN","DGRPE",143,0) ; patch DG*5.3*985; jam - NOK - do not copy phone number when copying patient address. "RTN","DGRPE",144,0) ; patch DG*5.3*997; jam - copy country/province/postal code "RTN","DGRPE",145,0) ;S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),DGPHONE=$S($D(^(.13)):$P(^(.13),U,1),1:""),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_DGPHONE_U_$P(Y,U,10) "RTN","DGRPE",146,0) ;S X=$S($D(^DPT(DA,.11)):^(.11),1:""),DGZ4=$P(X,U,12),Y=$S($D(^(DGADD)):^(DGADD),1:""),^(DGADD)=$P(Y,U,1)_U_$P(Y,U,2)_U_$P(X,U,1,6)_U_$P(Y,U,9)_U_$P(Y,U,10)_U_$P(Y,U,11)_U_$P(X,U,10)_U_$P(X,U,8)_U_$P(X,U,9) "RTN","DGRPE",147,0) ;I DGZ4 S DGPC=$S((DGADD=.33):1,(DGADD=.34):2,(DGADD=.211):3,(DGADD=.331):4,(DGADD=.311):5,(DGADD=.25):6,(DGADD=.21):7,1:0) S:DGPC $P(^DPT(DFN,.22),U,DGPC)=DGZ4 "RTN","DGRPE",148,0) ;K DGADD,DGPHONE Q "RTN","DGRPE",149,0) N DGPMA,DGDATA,DGERROR "RTN","DGRPE",150,0) ; get Perm Address "RTN","DGRPE",151,0) S DGPMA=$S($D(^DPT(DFN,.11)):^(.11),1:"") "RTN","DGRPE",152,0) ; set fields for copying Perm address to NOK "RTN","DGRPE",153,0) I DGADD=.21 D "RTN","DGRPE",154,0) . S DGDATA(.221)=$P(DGPMA,U,10) "RTN","DGRPE",155,0) . S DGDATA(.213)=$P(DGPMA,U,1) "RTN","DGRPE",156,0) . S DGDATA(.214)=$P(DGPMA,U,2) "RTN","DGRPE",157,0) . S DGDATA(.215)=$P(DGPMA,U,3) "RTN","DGRPE",158,0) . S DGDATA(.216)=$P(DGPMA,U,4) "RTN","DGRPE",159,0) . S DGDATA(.217)=$P(DGPMA,U,5) "RTN","DGRPE",160,0) . S DGDATA(.218)=$P(DGPMA,U,6) "RTN","DGRPE",161,0) . S DGDATA(.222)=$P(DGPMA,U,8) "RTN","DGRPE",162,0) . S DGDATA(.223)=$P(DGPMA,U,9) "RTN","DGRPE",163,0) ; set fields for copying Perm address to NOK2 "RTN","DGRPE",164,0) I DGADD=.211 D "RTN","DGRPE",165,0) . S DGDATA(.2101)=$P(DGPMA,U,10) "RTN","DGRPE",166,0) . S DGDATA(.2193)=$P(DGPMA,U,1) "RTN","DGRPE",167,0) . S DGDATA(.2194)=$P(DGPMA,U,2) "RTN","DGRPE",168,0) . S DGDATA(.2195)=$P(DGPMA,U,3) "RTN","DGRPE",169,0) . S DGDATA(.2196)=$P(DGPMA,U,4) "RTN","DGRPE",170,0) . S DGDATA(.2197)=$P(DGPMA,U,5) "RTN","DGRPE",171,0) . S DGDATA(.2198)=$P(DGPMA,U,6) "RTN","DGRPE",172,0) . S DGDATA(.2102)=$P(DGPMA,U,8) "RTN","DGRPE",173,0) . S DGDATA(.2103)=$P(DGPMA,U,9) "RTN","DGRPE",174,0) I $$UPD^DGENDBS(2,DFN,.DGDATA,.DGERROR) "RTN","DGRPE",175,0) K DGADD "RTN","DGRPE",176,0) Q "RTN","DGRPE",177,0) ; "RTN","DGRPE",178,0) DR109 ;Drop through (use same logic as DR203) "RTN","DGRPE",179,0) DR203 S DR(2,2.02)=".01RACE;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.02,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2031"";.02;@2031;" "RTN","DGRPE",180,0) S DR(2,2.06)=".01ETHNICITY;I $P($G(^DIC(10.3,+$P($G(^DPT(DA(1),.06,DA,0)),""^"",2),0)),""^"",2)=""S"" S Y=""@2032"";.02;@2032;" "RTN","DGRPE",181,0) Q "RTN","DGRPE",182,0) DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address is empty "RTN","DGRPE",183,0) Q:$G(^DPT(DFN,.115))="" "RTN","DGRPE",184,0) ; DG*5.3*1040 - Quit if timeout from previous field "RTN","DGRPE",185,0) Q:$D(DTOUT) "RTN","DGRPE",186,0) Q:+$G(DGTMOT) "RTN","DGRPE",187,0) ; If Residential Address exists, give user the option of copying residential to permanent address "RTN","DGRPE",188,0) W !,"The Patient has no Permanent Mailing Address." "RTN","DGRPE",189,0) D RESMVQ^DGREGCP1(DFN) "RTN","DGRPE",190,0) Q "RTN","DGRPE",191,0) DR111 ; Set DR string for Confidential Address categories "RTN","DGRPE",192,0) S DR(2,2.141)=".01;1//YES;" "RTN","DGRPE",193,0) ;S DR(2,2.14)=".01;1//"_"YES" "RTN","DGRPE",194,0) Q "RTN","DGRPE",195,0) DR207 ; DR string for preferred language ;*///* "RTN","DGRPE",196,0) S DR(2,2.07)=".01;.02//ENGLISH;D LANGDEL^DGRPE" "RTN","DGRPE",197,0) Q "RTN","DGRPE",198,0) ;DR301 ; set up variables for foreign address - REMOVE FOR PATCH 997 - REPLACED BELOW "RTN","DGRPE",199,0) N DG3,DG33 "RTN","DGRPE",200,0) S DG4=0 "RTN","DGRPE",201,0) S DG3=$P($G(^DPT(DFN,.11)),U,10) "RTN","DGRPE",202,0) S DG33=$O(^HL(779.004,"B","USA","")) "RTN","DGRPE",203,0) I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1 "RTN","DGRPE",204,0) Q "RTN","DGRPE",205,0) ; "RTN","DGRPE",206,0) DR301 ; jam; DG*5.3*997 - check for foreign address "RTN","DGRPE",207,0) N DG3,DG33 "RTN","DGRPE",208,0) S DG4=0 "RTN","DGRPE",209,0) S DG3=$P($G(^DPT(DFN,DGADD)),U,12) "RTN","DGRPE",210,0) S DG33=$O(^HL(779.004,"B","USA","")) "RTN","DGRPE",211,0) I $G(DG3)]"",(DG3'=$G(DG33)) S DG4=1 "RTN","DGRPE",212,0) Q "RTN","DGRPE",213,0) ; "RTN","DGRPE",214,0) PRF ; Write Proof needed for FV "RTN","DGRPE",215,0) W !?4,$C(7),"Proof is required for Filipino vet." "RTN","DGRPE",216,0) Q "RTN","DGRPE",217,0) ; "RTN","DGRPE",218,0) SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA "RTN","DGRPE",219,0) ; array with the BOS and component data for the SEQ military service "RTN","DGRPE",220,0) ; episode (1-3) "RTN","DGRPE",221,0) N I,Q,Z "RTN","DGRPE",222,0) K DIPA(32,SEQ) "RTN","DGRPE",223,0) S Q=$G(^DPT(DA,.32)),Z=$G(^(.3291)) "RTN","DGRPE",224,0) S DIPA(32,SEQ)=$P(Q,U,SEQ*5)_U_$P(Z,U,SEQ),DIPA("X"_SEQ)=$P(DIPA(32,SEQ),U) "RTN","DGRPE",225,0) Q "RTN","DGRPE",226,0) ; "RTN","DGRPE",227,0) WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will "RTN","DGRPE",228,0) ; be deleted "RTN","DGRPE",229,0) ; Returns Y to skip component if the component should not be asked "RTN","DGRPE",230,0) ; for this branch of service "RTN","DGRPE",231,0) N Z "RTN","DGRPE",232,0) I '$$CMP(X) S Y="@601"_SEQ "RTN","DGRPE",233,0) S Z=$G(DIPA(32,SEQ)) "RTN","DGRPE",234,0) Q:$S($P(Z,U,2)=""!($P(Z,U)=""):1,1:$P(Z,U)=X) "RTN","DGRPE",235,0) ; "RTN","DGRPE",236,0) I '$D(DIQUIET) W !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",! "RTN","DGRPE",237,0) Q "RTN","DGRPE",238,0) ; "RTN","DGRPE",239,0) CMP(X) ; Function to determine if service component is valid for "RTN","DGRPE",240,0) ; branch of service ien in X 0 = invalid 1 = valid "RTN","DGRPE",241,0) ; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS "RTN","DGRPE",242,0) Q $S('$G(X):0,X'>5!(X=9)!(X=10):1,1:0) "RTN","DGRPE",243,0) ; "RTN","DGRPE",244,0) YN1316(DFN) ;Email address indicator - DG*5.3*865 "RTN","DGRPE",245,0) N %,RSLT "RTN","DGRPE",246,0) S DIE("NO^")="" "RTN","DGRPE",247,0) P1316 ; "RTN","DGRPE",248,0) S %=0 "RTN","DGRPE",249,0) W !,"DOES THE PATIENT HAVE AN EMAIL ADDRESS? Y/N" "RTN","DGRPE",250,0) D YN^DICN "RTN","DGRPE",251,0) I %=0 W !," If the patient has a valid Email Address, please answer with 'Yes'.",!," If no Email Address please answer with 'No'." G P1316 "RTN","DGRPE",252,0) I %=-1 W !," EXIT NOT ALLOWED ??" G P1316 "RTN","DGRPE",253,0) S RSLT=$S(%=1:"Y",%=2:"N") "RTN","DGRPE",254,0) N FDA,IENS "RTN","DGRPE",255,0) Q:'$G(DFN) "RTN","DGRPE",256,0) S IENS=DFN_",",FDA(2,IENS,.1316)=RSLT "RTN","DGRPE",257,0) D FILE^DIE("","FDA") "RTN","DGRPE",258,0) Q RSLT "RTN","DGRPE",259,0) ; "RTN","DGRPE",260,0) INPXF207 ; Input transform for field 7 in file ;*///* "RTN","DGRPE",261,0) I $L(X)>60!($L(X)<1) K X Q "RTN","DGRPE",262,0) I X="*" S X="DECLINED TO ANSWER",FMT="?($X+3)" D EN^DDIOL(X,"",FMT) Q "RTN","DGRPE",263,0) I $D(X) DO "RTN","DGRPE",264,0) .N DIC S DIC(0)="EQMN",DIC="^DI(.85,",DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" "RTN","DGRPE",265,0) .D ^DIC S:+Y>0 X=$P(^DI(.85,+Y,0),U) I +Y<0 K X "RTN","DGRPE",266,0) Q "RTN","DGRPE",267,0) ; "RTN","DGRPE",268,0) XHELP207 ; This is a screen to be sure the language is a 'living' language, i.e.in use today and that it has the required 2-character code. ;*///* "RTN","DGRPE",269,0) N X S X="?" N DIC S DIC("S")="S DIC(""W"")="""" I $P(^DI(.85,+Y,0),U,7)=""L"",$P(^(0),U,2)]""""" S DIC(0)="EQM",DIC="^DI(.85," D ^DIC "RTN","DGRPE",270,0) Q "RTN","DGRPE",271,0) ; "RTN","DGRPE",272,0) LANGDEL ; If no language entered, remove the stub record ;*///* "RTN","DGRPE",273,0) Q:'$G(D1) "RTN","DGRPE",274,0) N X S X=$G(^DPT(DFN,.207,D1,0)) Q:X="" "RTN","DGRPE",275,0) I $P(X,U,2)="" DO "RTN","DGRPE",276,0) .W $C(7),!!,"No language was entered. Record deleted!",! H 3 "RTN","DGRPE",277,0) .S DIK="^DPT(DFN,.207,",DA=D1 D ^DIK K DIK "RTN","DGRPE",278,0) Q "RTN","DGRPP") 0^5^B22781007^B21625700 "RTN","DGRPP",1,0) DGRPP ;ALB/MRL,AEG,LBD,ASF,LEG - REGISTRATION SCREEN PROCESSOR ;Apr 05, 2020@15:16 "RTN","DGRPP",2,0) ;;5.3;Registration;**92,147,343,404,397,489,689,688,828,797,871,997,1014,1040**;Aug 13, 1993;Build 15 "RTN","DGRPP",3,0) ; "RTN","DGRPP",4,0) ;DGRPS : Screen to edit "RTN","DGRPP",5,0) ;DGRPSEL : If screen 9 (income screening) set to allowable selections "RTN","DGRPP",6,0) ; (V=Veteran, S=Spouse, D=Dependents) "RTN","DGRPP",7,0) ;DGRPSELT : If screen 9, type selected (V, S, or D or all if none specified) "RTN","DGRPP",8,0) ;DGRPAN : Selectable items on screen for edit (user input) "RTN","DGRPP",9,0) ;DGRPANP : Selectable items for print on page footer - i.e. 1-3 "RTN","DGRPP",10,0) ;DGRPANN : Selected item(s) extrapolated (screen_item) "RTN","DGRPP",11,0) ; "RTN","DGRPP",12,0) ; "RTN","DGRPP",13,0) EN ; "RTN","DGRPP",14,0) D:'$$BEGUPLD^DGENUPL3(DFN) "RTN","DGRPP",15,0) .D UNLOCK^DGENPTA1(DFN) "RTN","DGRPP",16,0) .D CKUPLOAD^DGENUPL3(DFN) "RTN","DGRPP",17,0) .I $$LOCK^DGENPTA1(DFN) "RTN","DGRPP",18,0) D ENDUPLD^DGENUPL3(DFN) "RTN","DGRPP",19,0) ; DG*5.3*1040 - If timed out, clean screen with W @IOF, use variable DGRPOUT to track timeout and exit "RTN","DGRPP",20,0) I $D(DTOUT)!(+$G(DGTMOT)) S DGRPOUT=1 W @IOF,!!! G QQ "RTN","DGRPP",21,0) ;jam; Patch DG*5.3*997 - include screen 11.5 group 1 to be editable when in View Reg option (DGRPV=1) "RTN","DGRPP",22,0) D Q1,WHICH^DGRPP1 W ! K DGRP S DGRPAN="" F I=1:1:$L(DGRPVV(DGRPS)) I $S('DGRPV:1,DGRPS=6:I=1!(I=2)!(I=3),DGRPS=11:I=5,DGRPS=11.5:I=1!(I=2),1:0) S:'$E(DGRPVV(DGRPS),I) DGRPAN=DGRPAN_I_"," ;LEG; DG*5.3*1014 added I=2 for <11.5> "RTN","DGRPP",23,0) D STR^DGRPP1 F I=$Y:1:20 W ! "RTN","DGRPP",24,0) ; remove COPY option DG*5.3*688 "RTN","DGRPP",25,0) I ("8^9"[DGRPS),($G(DGEFDT)'=DT) S Z="E" D W W "=ENTER new "_(DGISYR+1)_" data," "RTN","DGRPP",26,0) S Z="" D W W " to ",$S(DGRPS5) D CHOICE "RTN","DGRPP",48,0) I DGDR']"" D ^DGRPH S X=DGRPS G SCRX "RTN","DGRPP",49,0) D ^DGRPE G QQ:'$D(^DPT(DFN,0)) S X=DGRPS G SCRX "RTN","DGRPP",50,0) Q I 'DGELVER D:$S(DGRPOUT:0,'$D(DGRPV):0,'DGRPV:1,1:0) LT^DGRPP1 "RTN","DGRPP",51,0) K DGDEP,DGINC,DGINR,DGMTC,DGMTED,DGREL,DGTOT,DGSP "RTN","DGRPP",52,0) K DGCH,DGGTOT,DGIRI,DGPRI,DGRPSE1,DGNOCOPY "RTN","DGRPP",53,0) D SENSCHK "RTN","DGRPP",54,0) I 'DGRPV S DGEDCN=1 D ^DGRPC K DGEDCN "RTN","DGRPP",55,0) QQ K DGRPNA,DGRPS,DGRPTYPE,DGRPU,DGRPV,DGRPVV,DGRPW,DGVI,DGVO,DGRPCM,DGELVER,DGRPLAST "RTN","DGRPP",56,0) Q1 K %DT,C,DGA,DGA1,DGA2,DGAD,DGDR,DGRP,DGRPAG,DGRPAN,DGRPANN,DGRPANP,DGRPD,DGRPSEL,DGRPSELT,DGRPVR,DGRPX,DGAAC "RTN","DGRPP",57,0) ; DG*5.3*1040 - clean-up variable DGTMOT "RTN","DGRPP",58,0) K DIRUT,DUOUT,DTOUT,DGTMOT "RTN","DGRPP",59,0) K DIC,I,I1,I2,I3,J,X,X1,X2,X3,Y,Z,Z1 I $D(DFN)#2,DFN]"" S:$D(^DPT(DFN,0)) DA=DFN "RTN","DGRPP",60,0) Q "RTN","DGRPP",61,0) ; "RTN","DGRPP",62,0) SENSCHK ; check whether patient record should be made sensitive "RTN","DGRPP",63,0) N ELIG,FLAG,X "RTN","DGRPP",64,0) S ELIG=0,FLAG=0 "RTN","DGRPP",65,0) I '$D(^DPT($G(DFN),0)) Q ; patient not defined "RTN","DGRPP",66,0) I $D(^DGSL(38.1,DFN,0)) Q ; patient already in dg security log file "RTN","DGRPP",67,0) S X=$S($D(^DPT(DFN,"TYPE")):+^("TYPE"),1:"") I $D(^DG(391,+X,0)),$P(^(0),"^",4) D SEC Q:FLAG "RTN","DGRPP",68,0) F S ELIG=$O(^DPT(DFN,"E",ELIG)) Q:'ELIG D Q:FLAG "RTN","DGRPP",69,0) . S X=$G(^DIC(8,ELIG,0)) "RTN","DGRPP",70,0) . I $P(X,"^",12) D SEC "RTN","DGRPP",71,0) Q "RTN","DGRPP",72,0) ; "RTN","DGRPP",73,0) SEC ;if patient type says make record sensitive, add to security log file "RTN","DGRPP",74,0) K DD,DO S DIC="^DGSL(38.1,",(X,DINUM)=DFN,DIC(0)="L",DIC("DR")="2///1;3////"_DUZ_";4///NOW;" D FILE^DICN "RTN","DGRPP",75,0) I $D(^DGSL(38.1,DFN,0)) W !!,"===> Record has been classified as sensitive." S FLAG=1 "RTN","DGRPP",76,0) K DIC,X,DINUM,DA,DD,DO,Y "RTN","DGRPP",77,0) Q "RTN","DGRPP",78,0) ; "RTN","DGRPP",79,0) CHOICE ;parse out which items were selected for edit "RTN","DGRPP",80,0) ; "RTN","DGRPP",81,0) ;DGCH=choice to be parsed (either number or number-number) "RTN","DGRPP",82,0) ; "RTN","DGRPP",83,0) N DGFL S DGFL=0 "RTN","DGRPP",84,0) I DGCH["-" Q:DGCH'?1.2N1"-"1.2N!($P(DGCH,"-",2)>17) F J=$P(DGCH,"-",1):1:$P(DGCH,"-",2) I DGRPAN[(J_",") D:(DGRPS=9) SCR9 I 'DGFL S DGDR=DGDR_(DGRPS*100+J)_"," "RTN","DGRPP",85,0) I DGCH'["-",DGCH?1.2N,(DGRPAN[(DGCH_",")) S DGDR=DGDR_(DGRPS*100+DGCH)_"," "RTN","DGRPP",86,0) Q "RTN","DGRPP",87,0) ; "RTN","DGRPP",88,0) NEXT ;find next available screen...goto "RTN","DGRPP",89,0) I DGRPS=DGRPLAST G Q ;last screen and return...quit "RTN","DGRPP",90,0) S X=DGRPLAST "RTN","DGRPP",91,0) F I=DGRPS+1:1 S J=$E(DGRPVV,I) Q:J']"" I 'J S X=I Q "RTN","DGRPP",92,0) I DGRPS=1 S X=1.1 "RTN","DGRPP",93,0) ;LEG; DG*5.3*997; added screen 11.5 "RTN","DGRPP",94,0) I DGRPS=11 S X=11.5 "RTN","DGRPP",95,0) I DGRPS=11.5 S X=12 "RTN","DGRPP",96,0) SCRX ;goto screen X "RTN","DGRPP",97,0) I X[".",X'=1.1,X'=11.5 S X=$P(X,".",1) ;ASF; DG*5.3*997 ; Added screen 11.5 "RTN","DGRPP",98,0) G:X=1.1 ^DGRPCADD "RTN","DGRPP",99,0) ;ASF; DG*5.3*997; add condition for 11.5 "RTN","DGRPP",100,0) G:X=11.5 ^DGRP11A "RTN","DGRPP",101,0) G:(X'=1.1)&(X'=11.5) @("^DGRP"_X) ;goto next available screen; "RTN","DGRPP",102,0) W ;write highlighted text on screen (if parameter on) "RTN","DGRPP",103,0) I IOST="C-QUME",$L(DGVI)'=2 W Z "RTN","DGRPP",104,0) E W @DGVI,Z,@DGVO "RTN","DGRPP",105,0) Q "RTN","DGRPP",106,0) ; "RTN","DGRPP",107,0) SCR9 ; see if MT is completed. Allow only selective editing if so "RTN","DGRPP",108,0) I 'DGMTC Q "RTN","DGRPP",109,0) I '$D(DGRPSELT) S:DGMTC=1 DGFL=1 Q ;if no non-mt dependents "RTN","DGRPP",110,0) I DGRPSELT="S",$D(DGMTC("S")) Q "RTN","DGRPP",111,0) I DGRPSELT="D",$D(DGMTC("D")) Q "RTN","DGRPP",112,0) S DGFL=1 "RTN","DGRPP",113,0) Q "VER") 8.0^22.2 "BLD",11986,6) ^912 **END** **END**