DGRSTBAD ;JDH,EG,PHH,ARF-STATE FILE REPORT ; 03/16/2007 4:15 PM
;;5.3;Registration;**694,738,1056**;Aug 13, 1993;Build 18
Q
EN N %ZIS,DGNS,DIR,X,Y,DGRPTYP,DIRUT,MSG,POP,ZTSK
S DIR("A")="Report on States Not Recognized by AAC or Inactive Counties for"
S DGRPTYP(1)="US and US Possessions Only"
S DGRPTYP(2)="Foreign Addresses Only"
S DIR("B")=1
S DIR(0)="S^1:"_DGRPTYP(1)_";2:"_DGRPTYP(2)_";3:Both"
D ^DIR G:$D(DIRUT) EXIT
S DGRPTYP=Y
S MSG(1)=""
S MSG(2)="This report may take a long time to generate. It is recommended that the report"
S MSG(3)="be queued to print."
S MSG(4)=""
D BMES^XPDUTL(.MSG)
S %ZIS="Q" D ^%ZIS G:POP EXIT
S DGNS="DGRSTBAD"
I $D(IO("Q")) D ZTSK G EXIT
D PROC(DGNS,.DGRPTYP),^%ZISC
Q
EXIT D HOME^%ZIS
Q
;
ZTSK ;
N ZTSAVE,ZTDTH,ZTRTN,ZTDESC,Y
S (ZTSAVE("DGRPTYP"),ZTSAVE("DGRPTYP("),ZTSAVE("DGNS"))=""
S %DT("A")="Requested Start Time: ",%DT="FATE"
S %DT(0)="NOW",%DT("B")="NOW" D ^%DT K %DT(0) I Y<0 Q
S ZTDTH=Y
S ZTDESC="INVALID STATE/INACTIVE COUNTY REPORT"
S ZTRTN="PROC^"_DGNS_"(DGNS,.DGRPTYP)"
D ^%ZTLOAD
I $D(ZTSK) D
.W !!,"REPORT QUEUED"
E W !!,"REPORT NOT QUEUED"
Q
;
PROC(DGNS,DGRPTYP) ;
N X,DGFARR,DGFORR,DGSARR,DFN,DGD1,DGGLB,DGFILEP,DGPARR,DGIENS,DGFILE,DGNODE,DGPTYP,DGTARR,DGNAME
N DGIENS,DGSSN,DGPAGE,DGFLDNO,DGFLDS,DGPTR,DGTXT,DGFLD,DGQUIT,DGEND,DGSTRT,X1
S DGFILE=2
S DGGLB="^DPT"
K ^TMP($J,DGNS)
D FILE2(.DGFORR,"FOTXT")
D FILE2(.DGFARR,"FATXT")
S DGSTRT=$S(DGRPTYP=3:1,1:DGRPTYP)
S DGEND=$S(DGRPTYP=3:2,1:DGRPTYP)
S DFN=0
F S DFN=$O(^DPT(DFN)) Q:'DFN D
. K DGPARR
. I $$ISACT(DFN)'="Y" Q
. D FLDL
. Q
D RPT(DGNS,.DGRPTYP,DGSTRT,DGEND)
D XMY(.DGSARR,.DGRPTYP)
K ^TMP($J,DGNS)
Q
;
FLDL ;
I DGRPTYP'=2 D
. S DGFILEP=0
. F S DGFILEP=$O(DGFARR(1,DGFILEP)) Q:'DGFILEP D FLDLG
. Q
I DGRPTYP'=1 D
. S DGFILEP=0
. F S DGFILEP=$O(DGFORR(1,DGFILEP)) Q:'DGFILEP D FLDLG
. Q
D:$D(DGPARR) BUILD(DGNS,DFN,.DGPARR,.DGFARR,.DGSARR)
Q
FLDLG ;
I DGFILEP=DGFILE D
. S DGIENS=DFN_","
. D CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
. Q
E D
. S X=+$O(^DD(DGFILE,"SB",DGFILEP,0))
. S DGNODE=$P($P($G(^DD(DGFILE,X,0)),U,4),";") Q:'$L(DGNODE)
. S DGD1=0
. F S DGD1=$O(@DGGLB@(DFN,DGNODE,DGD1)) Q:'DGD1 D
.. S DGIENS=DGD1_","_DFN_","
.. D CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
.. Q
. Q
Q
CHECK1(DGRPTYP,DGFARR,DGFORR,DGFILEP,DGIENS,DGPARR,DGSTRT,DGEND) ;
;
;For each report type
F DGPTYP=DGSTRT:1:DGEND D CHG
Q
CHG ;
N FOREIGN
;Extract appropriate fields for report type
I DGPTYP=1 S DGFLDS=DGFARR(1,DGFILEP)
E S DGFLDS=DGFORR(1,DGFILEP)
K DGTARR,DGERR,SDQUERY,SDQDATA
N I D GETS^DIQ(DGFILEP,DGIENS,DGFLDS,"I","DGTARR","DGERR")
S DGFLD=0
F S DGFLD=$O(DGTARR(DGFILEP,DGIENS,DGFLD)) Q:'DGFLD D
. S DGPTR=DGTARR(DGFILEP,DGIENS,DGFLD,"I") Q:'DGPTR
. S FOREIGN=$$FOREIGN(DGPTR)
. I FOREIGN="Y",DGPTYP=1 Q
. I FOREIGN="N",DGPTYP=2 Q
. ;Check county inactive date for both foreign and US
. I DGFLD=.117 D
.. S X1=DGTARR(DGFILEP,DGIENS,.115,"I")
.. S X=$G(^DIC(5,X1,1,DGPTR,0))
.. S:$P(X,U,5)!$D(DGPARR(DGPTYP,DGFILEP,DGIENS,.115)) DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$P(X,U)
.. Q
. S X=$G(^DIC(5,DGPTR,0))
. I '$P(X,U,5)!($E($P(X,U,1),1)="Z") S DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$P(X,U)
. Q
Q
;
BUILD(DGNS,DGDO,DGPARR,DGFARR,DGSARR) ;
;
N X,DGNAME,DGSSN,DGPTYP
S X=$G(^DPT(DFN,0))
S DGNAME=$P(X,U) Q:'$L(DGNAME)
S DGSSN=$P(X,U,9)
S:'$L(DGSSN) DGSSN="NONE"
S DGPTYP=0
F S DGPTYP=$O(DGPARR(DGPTYP)) Q:'DGPTYP D DGFILEP
Q
DGFILEP ;
N DGFILEP
S DGFILEP=0
F S DGFILEP=$O(DGPARR(DGPTYP,DGFILEP)) Q:'DGFILEP D DGIENS
Q
DGIENS ;
N DGIENS
S DGIENS=""
F S DGIENS=$O(DGPARR(DGPTYP,DGFILEP,DGIENS)) Q:DGIENS="" D DGFLD
Q
DGFLD ;
N DGFLD
S DGFLD=0
F S DGFLD=$O(DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)) Q:'DGFLD D
. I DGPTYP=1 D
.. S ^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFARR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
.. S DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD))=$G(DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD)))+1
.. Q
. I DGPTYP=2 D
.. S ^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFORR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
.. S DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD))=$G(DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD)))+1
.. Q
. Q
Q
;
HDR(DGRPTYP,DGPTYP,DGPAGE) ;
N DGQUIT
S DGQUIT=0
I DGPAGE,$E(IOST,1,2)="C-" K X,Y,DIR S DIR(0)="E" D ^DIR S DGQUIT=$D(DIRUT)
D:'DGQUIT
.W @IOF
.S X="Report of States Not Recognized by AAC and Inactive Counties"
.W ?(IOM\2-($L(X)\2)),X
.S X=DGRPTYP(DGPTYP)
.W !,?(IOM\2-($L(X)\2)),X
.S DGPAGE=DGPAGE+1
.W ?(IOM-10),"PAGE: "_DGPAGE
.W !!,"NAME",?26,"SSN",?38,"FIELD",?68,"STATE/COUNTY"
.W !
Q DGQUIT
;
RPT(DGNS,DGRPTYP,DGSTRT,DGEND) ;
N DGPAGE,DGQUIT,DGPTYP
S DGPAGE=0
S DGQUIT=0
S DGPTYP=0
F DGPTYP=DGSTRT:1:DGEND Q:DGQUIT D RPTG
Q
RPTG ;
N DGNAME,CNT
S CNT=0
S DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE)
Q:DGQUIT
S DGNAME=""
F S DGNAME=$O(^TMP($J,DGNS,DGPTYP,DGNAME)) Q:'$L(DGNAME) Q:DGQUIT D RDGSSN
W !!,"Total records reported: ",CNT
Q
RDGSSN ;
N DGSSN
S DGSSN=""
F S DGSSN=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN)) Q:'$L(DGSSN) Q:DGQUIT D RDGIENS
Q
RDGIENS ;
N DGIENS
S DGIENS=""
F S DGIENS=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS)) Q:DGIENS="" Q:DGQUIT D RDGTXT
Q
RDGTXT ;
N DGTEXT
S DGTXT=""
F S DGTXT=$O(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT)) Q:'$L(DGTXT) D Q:DGQUIT
. I $Y>(IOSL-4) S DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE) Q:DGQUIT
. S DGTEXT=$G(^TMP($J,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT))
. W !,$E(DGNAME,1,25),?26,DGSSN,?38,DGTXT,?68,$E($P(DGTEXT,U,1),1,12)
. S CNT=CNT+1
. Q
Q
;
XMY(DGSARR,DGRPTYP) ;
N DGTXT,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DGLINE,X
S XMY(DUZ)="",XMTEXT="MSG(",XMDUZ=.5
S XMSUB="Invalid State/Inactive County Report Summary"
S MSG(1)="The following counts have been found in the PATIENT file:"
S MSG(5)=""
S DGPTYP=0
S DGLINE=10
I DGRPTYP'=2,'$D(DGSARR(1)) D
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=DGRPTYP(1)
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
. Q
I DGRPTYP'=1,'$D(DGSARR(2)) D
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=DGRPTYP(2)
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
. Q
F S DGPTYP=$O(DGSARR(DGPTYP)) Q:'DGPTYP D
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=""
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=DGRPTYP(DGPTYP)
. S DGLINE=DGLINE+1
. S MSG(DGLINE)=""
. S DGTXT=""
. F S DGTXT=$O(DGSARR(DGPTYP,DGTXT)) Q:'$L(DGTXT) D
.. S DGLINE=DGLINE+1
.. S X="",$P(X," ",32-$L(DGTXT))=""
.. S MSG(DGLINE)=" "_DGTXT_X_DGSARR(DGPTYP,DGTXT)
.. Q
. Q
D ^XMD
Q
;
FILE2(DGFARR,TAG) ;
N I,X,DGFILED,DGFLDNO
F I=1:1 S X=$P($T(@TAG+I),";;",2) Q:X="END" D
.S DGFILED=$P(X,";"),DGFLDNO=$P(X,";",2),DGFARR(0,DGFILED,DGFLDNO)=$P(X,";",3) S:'$D(DGFARR(1,DGFILED)) DGFARR(1,DGFILED)=""
.S DGFARR(1,DGFILED)=DGFARR(1,DGFILED)_$E(";",$L(DGFARR(1,DGFILED))>0)_DGFLDNO
Q
;
FOTXT ;DG*5.3*1056 - Replaced Permanent with Mailing of the following line of code
;;2;.115;Mailing Address - State
;;2;.1215;Temporary Address - State
;;2;.1415;Confidential Address - State
;;END
;
FATXT ;DG*5.3*1056 - Replaced Permanent with Mailing on the State (.115) and County (.117) lines of code
;;2;.093;Place of Birth
;;2;.115;Mailing Address - State
;;2;.117;Mailing Address - County
;;2;.1215;Temporary Address - State
;;2;.12111;Temporary Address - County
;;2;.1415;Confidential Address - State
;;2;.14111;Confidential Address - County
;;2;.1654;Ineligible TWX
;;2;.1659;Missing Person TWX
;;2;.217;Next of Kin
;;2;.2197;Next of Kin 2
;;2;.256;Spouse's Employer
;;2;.2917;VA Guardian
;;2;.2927;Civil Guardian
;;2;.3117;Employer
;;2;.3317;Emergency Contact 2
;;2;.337;Emergency Contact
;;2;.347;Designee
;;2;2.06;Insurance Type - Emp Claims
;;2;3.09;Insurance Type - Insured's
;;2;13;Insurance Type - Agent's
;;2;35;Attorney
;;END
;
ISACT(DFN) ;
N X,DGACT,HLQ
S HLQ=""""""
S DGACT=$P($G(^DPT(DFN,.35)),U) ; date of death
I DGACT Q "N"
S DGACT=$S(+$$LTD^VAFHUTL(DFN)=-1:0,1:+$$LTD^VAFHUTL(DFN)) ; active appointment
S:'DGACT DGACT=$$PHARM^IVMLDEM6(DFN) ; active RX
Q $S(DGACT:"Y",1:"N")
;
FOREIGN(STATE) ;uses state to determine foreign address
;someday should use country codes in the patient file
N DESC,X
I $G(STATE)="" Q "N"
S X=$G(^DIC(5,STATE,0))
I $P(X,"^",6)=1 Q "N"
Q "Y"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRSTBAD 8649 printed Apr 09, 2024@22:02:47 Page 2
DGRSTBAD ;JDH,EG,PHH,ARF-STATE FILE REPORT ; 03/16/2007 4:15 PM
+1 ;;5.3;Registration;**694,738,1056**;Aug 13, 1993;Build 18
+2 QUIT
EN NEW %ZIS,DGNS,DIR,X,Y,DGRPTYP,DIRUT,MSG,POP,ZTSK
+1 SET DIR("A")="Report on States Not Recognized by AAC or Inactive Counties for"
+2 SET DGRPTYP(1)="US and US Possessions Only"
+3 SET DGRPTYP(2)="Foreign Addresses Only"
+4 SET DIR("B")=1
+5 SET DIR(0)="S^1:"_DGRPTYP(1)_";2:"_DGRPTYP(2)_";3:Both"
+6 DO ^DIR
if $DATA(DIRUT)
GOTO EXIT
+7 SET DGRPTYP=Y
+8 SET MSG(1)=""
+9 SET MSG(2)="This report may take a long time to generate. It is recommended that the report"
+10 SET MSG(3)="be queued to print."
+11 SET MSG(4)=""
+12 DO BMES^XPDUTL(.MSG)
+13 SET %ZIS="Q"
DO ^%ZIS
if POP
GOTO EXIT
+14 SET DGNS="DGRSTBAD"
+15 IF $DATA(IO("Q"))
DO ZTSK
GOTO EXIT
+16 DO PROC(DGNS,.DGRPTYP)
DO ^%ZISC
+17 QUIT
EXIT DO HOME^%ZIS
+1 QUIT
+2 ;
ZTSK ;
+1 NEW ZTSAVE,ZTDTH,ZTRTN,ZTDESC,Y
+2 SET (ZTSAVE("DGRPTYP"),ZTSAVE("DGRPTYP("),ZTSAVE("DGNS"))=""
+3 SET %DT("A")="Requested Start Time: "
SET %DT="FATE"
+4 SET %DT(0)="NOW"
SET %DT("B")="NOW"
DO ^%DT
KILL %DT(0)
IF Y<0
QUIT
+5 SET ZTDTH=Y
+6 SET ZTDESC="INVALID STATE/INACTIVE COUNTY REPORT"
+7 SET ZTRTN="PROC^"_DGNS_"(DGNS,.DGRPTYP)"
+8 DO ^%ZTLOAD
+9 IF $DATA(ZTSK)
Begin DoDot:1
+10 WRITE !!,"REPORT QUEUED"
End DoDot:1
+11 IF '$TEST
WRITE !!,"REPORT NOT QUEUED"
+12 QUIT
+13 ;
PROC(DGNS,DGRPTYP) ;
+1 NEW X,DGFARR,DGFORR,DGSARR,DFN,DGD1,DGGLB,DGFILEP,DGPARR,DGIENS,DGFILE,DGNODE,DGPTYP,DGTARR,DGNAME
+2 NEW DGIENS,DGSSN,DGPAGE,DGFLDNO,DGFLDS,DGPTR,DGTXT,DGFLD,DGQUIT,DGEND,DGSTRT,X1
+3 SET DGFILE=2
+4 SET DGGLB="^DPT"
+5 KILL ^TMP($JOB,DGNS)
+6 DO FILE2(.DGFORR,"FOTXT")
+7 DO FILE2(.DGFARR,"FATXT")
+8 SET DGSTRT=$SELECT(DGRPTYP=3:1,1:DGRPTYP)
+9 SET DGEND=$SELECT(DGRPTYP=3:2,1:DGRPTYP)
+10 SET DFN=0
+11 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
Begin DoDot:1
+12 KILL DGPARR
+13 IF $$ISACT(DFN)'="Y"
QUIT
+14 DO FLDL
+15 QUIT
End DoDot:1
+16 DO RPT(DGNS,.DGRPTYP,DGSTRT,DGEND)
+17 DO XMY(.DGSARR,.DGRPTYP)
+18 KILL ^TMP($JOB,DGNS)
+19 QUIT
+20 ;
FLDL ;
+1 IF DGRPTYP'=2
Begin DoDot:1
+2 SET DGFILEP=0
+3 FOR
SET DGFILEP=$ORDER(DGFARR(1,DGFILEP))
if 'DGFILEP
QUIT
DO FLDLG
+4 QUIT
End DoDot:1
+5 IF DGRPTYP'=1
Begin DoDot:1
+6 SET DGFILEP=0
+7 FOR
SET DGFILEP=$ORDER(DGFORR(1,DGFILEP))
if 'DGFILEP
QUIT
DO FLDLG
+8 QUIT
End DoDot:1
+9 if $DATA(DGPARR)
DO BUILD(DGNS,DFN,.DGPARR,.DGFARR,.DGSARR)
+10 QUIT
FLDLG ;
+1 IF DGFILEP=DGFILE
Begin DoDot:1
+2 SET DGIENS=DFN_","
+3 DO CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
+4 QUIT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 SET X=+$ORDER(^DD(DGFILE,"SB",DGFILEP,0))
+7 SET DGNODE=$PIECE($PIECE($GET(^DD(DGFILE,X,0)),U,4),";")
if '$LENGTH(DGNODE)
QUIT
+8 SET DGD1=0
+9 FOR
SET DGD1=$ORDER(@DGGLB@(DFN,DGNODE,DGD1))
if 'DGD1
QUIT
Begin DoDot:2
+10 SET DGIENS=DGD1_","_DFN_","
+11 DO CHECK1(DGRPTYP,.DGFARR,.DGFORR,DGFILEP,DGIENS,.DGPARR,DGSTRT,DGEND)
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
CHECK1(DGRPTYP,DGFARR,DGFORR,DGFILEP,DGIENS,DGPARR,DGSTRT,DGEND) ;
+1 ;
+2 ;For each report type
+3 FOR DGPTYP=DGSTRT:1:DGEND
DO CHG
+4 QUIT
CHG ;
+1 NEW FOREIGN
+2 ;Extract appropriate fields for report type
+3 IF DGPTYP=1
SET DGFLDS=DGFARR(1,DGFILEP)
+4 IF '$TEST
SET DGFLDS=DGFORR(1,DGFILEP)
+5 KILL DGTARR,DGERR,SDQUERY,SDQDATA
+6 NEW I
DO GETS^DIQ(DGFILEP,DGIENS,DGFLDS,"I","DGTARR","DGERR")
+7 SET DGFLD=0
+8 FOR
SET DGFLD=$ORDER(DGTARR(DGFILEP,DGIENS,DGFLD))
if 'DGFLD
QUIT
Begin DoDot:1
+9 SET DGPTR=DGTARR(DGFILEP,DGIENS,DGFLD,"I")
if 'DGPTR
QUIT
+10 SET FOREIGN=$$FOREIGN(DGPTR)
+11 IF FOREIGN="Y"
IF DGPTYP=1
QUIT
+12 IF FOREIGN="N"
IF DGPTYP=2
QUIT
+13 ;Check county inactive date for both foreign and US
+14 IF DGFLD=.117
Begin DoDot:2
+15 SET X1=DGTARR(DGFILEP,DGIENS,.115,"I")
+16 SET X=$GET(^DIC(5,X1,1,DGPTR,0))
+17 if $PIECE(X,U,5)!$DATA(DGPARR(DGPTYP,DGFILEP,DGIENS,.115))
SET DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$PIECE(X,U)
+18 QUIT
End DoDot:2
+19 SET X=$GET(^DIC(5,DGPTR,0))
+20 IF '$PIECE(X,U,5)!($EXTRACT($PIECE(X,U,1),1)="Z")
SET DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)=$PIECE(X,U)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
BUILD(DGNS,DGDO,DGPARR,DGFARR,DGSARR) ;
+1 ;
+2 NEW X,DGNAME,DGSSN,DGPTYP
+3 SET X=$GET(^DPT(DFN,0))
+4 SET DGNAME=$PIECE(X,U)
if '$LENGTH(DGNAME)
QUIT
+5 SET DGSSN=$PIECE(X,U,9)
+6 if '$LENGTH(DGSSN)
SET DGSSN="NONE"
+7 SET DGPTYP=0
+8 FOR
SET DGPTYP=$ORDER(DGPARR(DGPTYP))
if 'DGPTYP
QUIT
DO DGFILEP
+9 QUIT
DGFILEP ;
+1 NEW DGFILEP
+2 SET DGFILEP=0
+3 FOR
SET DGFILEP=$ORDER(DGPARR(DGPTYP,DGFILEP))
if 'DGFILEP
QUIT
DO DGIENS
+4 QUIT
DGIENS ;
+1 NEW DGIENS
+2 SET DGIENS=""
+3 FOR
SET DGIENS=$ORDER(DGPARR(DGPTYP,DGFILEP,DGIENS))
if DGIENS=""
QUIT
DO DGFLD
+4 QUIT
DGFLD ;
+1 NEW DGFLD
+2 SET DGFLD=0
+3 FOR
SET DGFLD=$ORDER(DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD))
if 'DGFLD
QUIT
Begin DoDot:1
+4 IF DGPTYP=1
Begin DoDot:2
+5 SET ^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFARR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
+6 SET DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD))=$GET(DGSARR(DGPTYP,DGFARR(0,DGFILEP,DGFLD)))+1
+7 QUIT
End DoDot:2
+8 IF DGPTYP=2
Begin DoDot:2
+9 SET ^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGFORR(0,DGFILEP,DGFLD))=DGPARR(DGPTYP,DGFILEP,DGIENS,DGFLD)
+10 SET DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD))=$GET(DGSARR(DGPTYP,DGFORR(0,DGFILEP,DGFLD)))+1
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
HDR(DGRPTYP,DGPTYP,DGPAGE) ;
+1 NEW DGQUIT
+2 SET DGQUIT=0
+3 IF DGPAGE
IF $EXTRACT(IOST,1,2)="C-"
KILL X,Y,DIR
SET DIR(0)="E"
DO ^DIR
SET DGQUIT=$DATA(DIRUT)
+4 if 'DGQUIT
Begin DoDot:1
+5 WRITE @IOF
+6 SET X="Report of States Not Recognized by AAC and Inactive Counties"
+7 WRITE ?(IOM\2-($LENGTH(X)\2)),X
+8 SET X=DGRPTYP(DGPTYP)
+9 WRITE !,?(IOM\2-($LENGTH(X)\2)),X
+10 SET DGPAGE=DGPAGE+1
+11 WRITE ?(IOM-10),"PAGE: "_DGPAGE
+12 WRITE !!,"NAME",?26,"SSN",?38,"FIELD",?68,"STATE/COUNTY"
+13 WRITE !
End DoDot:1
+14 QUIT DGQUIT
+15 ;
RPT(DGNS,DGRPTYP,DGSTRT,DGEND) ;
+1 NEW DGPAGE,DGQUIT,DGPTYP
+2 SET DGPAGE=0
+3 SET DGQUIT=0
+4 SET DGPTYP=0
+5 FOR DGPTYP=DGSTRT:1:DGEND
if DGQUIT
QUIT
DO RPTG
+6 QUIT
RPTG ;
+1 NEW DGNAME,CNT
+2 SET CNT=0
+3 SET DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE)
+4 if DGQUIT
QUIT
+5 SET DGNAME=""
+6 FOR
SET DGNAME=$ORDER(^TMP($JOB,DGNS,DGPTYP,DGNAME))
if '$LENGTH(DGNAME)
QUIT
if DGQUIT
QUIT
DO RDGSSN
+7 WRITE !!,"Total records reported: ",CNT
+8 QUIT
RDGSSN ;
+1 NEW DGSSN
+2 SET DGSSN=""
+3 FOR
SET DGSSN=$ORDER(^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN))
if '$LENGTH(DGSSN)
QUIT
if DGQUIT
QUIT
DO RDGIENS
+4 QUIT
RDGIENS ;
+1 NEW DGIENS
+2 SET DGIENS=""
+3 FOR
SET DGIENS=$ORDER(^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS))
if DGIENS=""
QUIT
if DGQUIT
QUIT
DO RDGTXT
+4 QUIT
RDGTXT ;
+1 NEW DGTEXT
+2 SET DGTXT=""
+3 FOR
SET DGTXT=$ORDER(^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT))
if '$LENGTH(DGTXT)
QUIT
Begin DoDot:1
+4 IF $Y>(IOSL-4)
SET DGQUIT=$$HDR(.DGRPTYP,DGPTYP,.DGPAGE)
if DGQUIT
QUIT
+5 SET DGTEXT=$GET(^TMP($JOB,DGNS,DGPTYP,DGNAME,DGSSN,DGIENS,DGTXT))
+6 WRITE !,$EXTRACT(DGNAME,1,25),?26,DGSSN,?38,DGTXT,?68,$EXTRACT($PIECE(DGTEXT,U,1),1,12)
+7 SET CNT=CNT+1
+8 QUIT
End DoDot:1
if DGQUIT
QUIT
+9 QUIT
+10 ;
XMY(DGSARR,DGRPTYP) ;
+1 NEW DGTXT,XMDUZ,XMSUB,XMY,XMTEXT,MSG,DGLINE,X
+2 SET XMY(DUZ)=""
SET XMTEXT="MSG("
SET XMDUZ=.5
+3 SET XMSUB="Invalid State/Inactive County Report Summary"
+4 SET MSG(1)="The following counts have been found in the PATIENT file:"
+5 SET MSG(5)=""
+6 SET DGPTYP=0
+7 SET DGLINE=10
+8 IF DGRPTYP'=2
IF '$DATA(DGSARR(1))
Begin DoDot:1
+9 SET DGLINE=DGLINE+1
+10 SET MSG(DGLINE)=DGRPTYP(1)
+11 SET DGLINE=DGLINE+1
+12 SET MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
+13 QUIT
End DoDot:1
+14 IF DGRPTYP'=1
IF '$DATA(DGSARR(2))
Begin DoDot:1
+15 SET DGLINE=DGLINE+1
+16 SET MSG(DGLINE)=DGRPTYP(2)
+17 SET DGLINE=DGLINE+1
+18 SET MSG(DGLINE)=" No Invalid States or Inactive Counties Found"
+19 QUIT
End DoDot:1
+20 FOR
SET DGPTYP=$ORDER(DGSARR(DGPTYP))
if 'DGPTYP
QUIT
Begin DoDot:1
+21 SET DGLINE=DGLINE+1
+22 SET MSG(DGLINE)=""
+23 SET DGLINE=DGLINE+1
+24 SET MSG(DGLINE)=DGRPTYP(DGPTYP)
+25 SET DGLINE=DGLINE+1
+26 SET MSG(DGLINE)=""
+27 SET DGTXT=""
+28 FOR
SET DGTXT=$ORDER(DGSARR(DGPTYP,DGTXT))
if '$LENGTH(DGTXT)
QUIT
Begin DoDot:2
+29 SET DGLINE=DGLINE+1
+30 SET X=""
SET $PIECE(X," ",32-$LENGTH(DGTXT))=""
+31 SET MSG(DGLINE)=" "_DGTXT_X_DGSARR(DGPTYP,DGTXT)
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
+34 DO ^XMD
+35 QUIT
+36 ;
FILE2(DGFARR,TAG) ;
+1 NEW I,X,DGFILED,DGFLDNO
+2 FOR I=1:1
SET X=$PIECE($TEXT(@TAG+I),";;",2)
if X="END"
QUIT
Begin DoDot:1
+3 SET DGFILED=$PIECE(X,";")
SET DGFLDNO=$PIECE(X,";",2)
SET DGFARR(0,DGFILED,DGFLDNO)=$PIECE(X,";",3)
if '$DATA(DGFARR(1,DGFILED))
SET DGFARR(1,DGFILED)=""
+4 SET DGFARR(1,DGFILED)=DGFARR(1,DGFILED)_$EXTRACT(";",$LENGTH(DGFARR(1,DGFILED))>0)_DGFLDNO
End DoDot:1
+5 QUIT
+6 ;
FOTXT ;DG*5.3*1056 - Replaced Permanent with Mailing of the following line of code
+1 ;;2;.115;Mailing Address - State
+2 ;;2;.1215;Temporary Address - State
+3 ;;2;.1415;Confidential Address - State
+4 ;;END
+5 ;
FATXT ;DG*5.3*1056 - Replaced Permanent with Mailing on the State (.115) and County (.117) lines of code
+1 ;;2;.093;Place of Birth
+2 ;;2;.115;Mailing Address - State
+3 ;;2;.117;Mailing Address - County
+4 ;;2;.1215;Temporary Address - State
+5 ;;2;.12111;Temporary Address - County
+6 ;;2;.1415;Confidential Address - State
+7 ;;2;.14111;Confidential Address - County
+8 ;;2;.1654;Ineligible TWX
+9 ;;2;.1659;Missing Person TWX
+10 ;;2;.217;Next of Kin
+11 ;;2;.2197;Next of Kin 2
+12 ;;2;.256;Spouse's Employer
+13 ;;2;.2917;VA Guardian
+14 ;;2;.2927;Civil Guardian
+15 ;;2;.3117;Employer
+16 ;;2;.3317;Emergency Contact 2
+17 ;;2;.337;Emergency Contact
+18 ;;2;.347;Designee
+19 ;;2;2.06;Insurance Type - Emp Claims
+20 ;;2;3.09;Insurance Type - Insured's
+21 ;;2;13;Insurance Type - Agent's
+22 ;;2;35;Attorney
+23 ;;END
+24 ;
ISACT(DFN) ;
+1 NEW X,DGACT,HLQ
+2 SET HLQ=""""""
+3 ; date of death
SET DGACT=$PIECE($GET(^DPT(DFN,.35)),U)
+4 IF DGACT
QUIT "N"
+5 ; active appointment
SET DGACT=$SELECT(+$$LTD^VAFHUTL(DFN)=-1:0,1:+$$LTD^VAFHUTL(DFN))
+6 ; active RX
if 'DGACT
SET DGACT=$$PHARM^IVMLDEM6(DFN)
+7 QUIT $SELECT(DGACT:"Y",1:"N")
+8 ;
FOREIGN(STATE) ;uses state to determine foreign address
+1 ;someday should use country codes in the patient file
+2 NEW DESC,X
+3 IF $GET(STATE)=""
QUIT "N"
+4 SET X=$GET(^DIC(5,STATE,0))
+5 IF $PIECE(X,"^",6)=1
QUIT "N"
+6 QUIT "Y"
