DG1010S1 ;ALB/MRL - SUPPLEMENTAL DATA SHEET FOR 10-10 ; 19 JUN 86
;;5.3;Registration;;Aug 13, 1993
;;MAS VERSION 5.1;
;
;INPUT: DFN = IEN OF PATIENT FILE
; DFN1 = INVERSE DISPOSTION TIME
EN ;
S DGLDOUBL="",$P(DGLDOUBL,"=",132)=""
S DGLSUP="",$P(DGLSUP,"- ",62)="",$P(DGLSUP,"- ",43)=" |"
S DGLSUP1="",$P(DGLSUP1,"-",123)="",$P(DGLSUP1,"-",86)="|"
F I="INE","DIS",0,.15,.24,.361 S DGP(I)=$G(^DPT(DFN,I))
S DGD=$G(^DPT(DFN,"DIS",DFN1,0)),Y=$P(DGD,U,1) X ^DD("DD") S DGAP=Y,DGCLK=$S($D(^VA(200,+$P(DGD,U,5),0)):$S($P(^(0),U,2)]"":$P(^(0),U,2)_"/"_$P(DGD,U,5),1:"unk/"_$P(DGD,U,5)),1:"unspecified"),DGNAM=$P(DGP(0),U,1)
S DGSS=$P(DGP(0),U,9),DGSS=$E(DGSS,1,3)_"-"_$E(DGSS,4,5)_"-"_$E(DGSS,6,10)
S DGLDOUBL=$E(DGLDOUBL,1,127)
I $$FIRST^DGUTL G Q^DG1010S2
W !?5,DGLDOUBL,!?5
S X=$$SITE^VASITE W $S((+X=-1):"FACILITY NOT IDENTIFIED",1:$P(X,U,2)_" ("_$P(X,U,3)_")")
W ?105,"SUPPLEMENTAL DATA SHEET",!?5,DGLDOUBL,!?5,"1. Applicant's Name: ",DGNAM,?90,"| 2. SSN: ",DGSS,!?5,DGLSUP1,!?5,"3. Other Name(s): "
S I1="" F I=0:0 S I=$O(^DPT(DFN,.01,I)) Q:I'>0 S I1=1,DGD=$P(^(I,0),U,1),DGD(1)=$P(^(0),U,2),DGD=DGD_$S($L(DGD(1)):" ("_$E(DGD(1),1,3)_"-"_$E(DGD(1),4,5)_"-"_$E(DGD(1),6,10)_")",1:"")_"; " W:(128-$X)<$L(DGD) !?9 W DGD
W:'I1 "NO ALIAS' ON FILE" K DGD,I,I1 S DGD=$S($L($P(DGP(0),U,10)):$P(DGP(0),U,10),1:"NO REMARKS CURRENTLY ENTERED FOR THIS APPLICANT") W !?5,DGLSUP1,!?5,"4. Remarks: ",DGD,!?5,DGLSUP1
S DGD=DGP(.24) W !?5,"5. Fathers Name: ",$S($L($P(DGD,U,1)):$P(DGD,U,1),1:"NOT SPECIFIED"),?90,"|"
W !?9,"Mothers Name: ",$S($L($P(DGD,U,2)):$P(DGD,U,2),1:"NOT SPECIFIED"),?90,"|",!?9,"Mothers Maiden Name: ",$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"NOT SPECIFIED"),?90,"|",!?5,DGLSUP1
W !?5,"6a. Enrollment Clinic(s): " S I1="" F I=0:0 S I=$O(^DPT(DFN,"DE",I)) Q:I'>0 I $P(^(I,0),U,2)'="I" S I1=I1+1,DGD=$S($D(^SC(+^(0),0)):$P(^(0),U,1)_", ",1:"") W:(128-$X)<$L(DGD) !?9 W DGD
W:'I1 "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME" K DGD,I,I1 W !?5,DGLSUP,!?5,"6b. Future Appointments: " S I1="",I2=DT_".9999"
F J=0:0 S I2=$O(^DPT(DFN,"S",I2)) Q:I2="" I $S($P(^(I2,0),U,2)']"":1,$P(^(0),U,2)="I":1,1:0) S DGD(1)=+$P(^(0),U,1),Y=I2 X ^DD("DD") S DGD=$S($D(^SC(+DGD(1),0)):$P(^(0),U,1),1:"UNKNOWN")_" ("_Y_"), ",I1=1 W:(128-$X)<$L(DGD) !?9 W DGD
W:'I1 "NO PENDING APPOINTMENTS ON FILE" W !?5,DGLSUP1,!?5,"7a. Last Admission: "
S DGAD=$S('$D(^DPT(DFN,.1)):0,'$L(^DPT(DFN,.1)):0,1:1),DGD=$O(^DGPM("ATID1",DFN,+$S(DGAD:$O(^DGPM("ATID1",DFN,0)),1:0))) I DGD'>0 W "NO PREVIOUS ADMISSIONS TO THIS FACILITY ON FILE" G EL
S DGD=$O(^DGPM("ATID1",DFN,DGD,0)) I $S('$D(^DGPM(+DGD,0)):1,'$D(^DGPT(+$P(^(0),"^",16),0)):1,1:0) W "LAST ADMISSION PTF DATA NO LONGER STORED" G EL
S DGD=+$P(^DGPM(+DGD,0),"^",16),Y=+^(0)
X ^DD("DD") W Y S Y=$P($S($D(^DGPT(DGD,70)):^(70),1:0),U,1) X ^DD("DD") W:Y]"" " (DISCHARGED '"_Y_"')" W !?5,DGLSUP,!?5,"7b. Discharge Diagnosis(es): " S I1=$S($D(^DGPT(DGD,"M",1,0)):^(0),1:0)
S I3="" F I=5:1:15 I I'=10 S I2=$P(I1,U,I) Q:'I2 S I3=1,I2=$S($D(^ICD9(I2,0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3)_"; ",1:"") W:(128-$X)<$L(I2) !?9 W I2
W:'I3 "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD YET",!?5,DGLSUP S DGD(1)=$S($D(^DGPT(DGD,70)):^(70),1:0),X="UNSPECIFIED",X=$S('DGD(1):X,$D(^ICD9(+$P(DGD(1),U,11),0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3),1:X)
W !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. Diagnosis Responsible for Greatest Length of Stay: " S X="UNSPECIFIED",X=$S('DGD(1):X,$D(^ICD9(+$P(DGD(1),U,10),0)):"("_$P(^(0),U,1)_")-"_$P(^(0),U,3),1:X) W X
EL W !?5,DGLSUP1 S DGD=DGP(.361),DGD(1)=$P(DGD,U,5),DGD(2)=$P(DGD,U,6),Y=$P(DGD,U,2),DGD=$P(DGD,U,1),DGD(1)=$S($L(DGD(1)):DGD(1),'$L(DGD):"NOT APPLICABLE",1:"NOT VERIFIED")
S DGD(2)=$S(+DGD(2):$S($D(^VA(200,+DGD(2),0)):$P(^(0),U,1),1:"UNKNOWN"),'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED") X:+Y ^DD("DD") S Y=$S($L(Y):Y,'$L(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED")
W !?5,"8. Eligibility Status: ",$S(DGD="P":"PENDING VERIFICATION",DGD="R":"PENDING RE-VERIFICATION",DGD="V":"VERIFIED",1:"UNKNOWN OR NONE"),?90,"| Status Date: ",Y,!?9,"Verification Method: ",DGD(1),?90,"| By: ",DGD(2)
S Y=$P(DGP(.15),U,2),DGD=DGP("INE") X:+Y ^DD("DD") S DGEL=$S('$L(Y)!(Y=0):1,1:0),Y=$S('DGEL:Y,1:"ELIGIBLE APPLICANT -- NOT APPLICABLE") W !?9,"Ineligible Date: ",Y I DGEL F I=1:1:4 S DGD(I)="NOT APPLICABLE"
G:DGEL C S DGD(1)=$P(DGD,U,1),DGD(1)=$S(DGD(1)=1:"VAMC",DGD(1)=2:"REGIONAL OFFICE",DGD(2)=3:"RPC",1:"UNKNOWN"),DGD(2)=$S($L($P(DGD,U,3)):$P(DGD,U,3),1:"CITY UNKNOWN"),DGD(3)=$S($D(^DIC(5,+$P(DGD,U,4),0)):$P(^(0),U,1),1:"STATE UNKNOWN")
S DGD(4)=$S($P(DGD,U,6)]"":$P(DGD,U,6),1:"VARO DECISION UNKNOWN")
C W ?90,"| TWX Source: ",DGD(1),!?9,"TWX City: ",DGD(2),?90,"| TWX State: ",$E(DGD(3),1,26),!?9,"VARO Decision: ",DGD(4),!?5,DGLSUP1
K DGAD,DGD,DGEL,I,I1,I2,Y G ^DG1010S2
DG1010S1 ;ALB/MRL - SUPPLEMENTAL DATA SHEET FOR 10-10 ; 19 JUN 86
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;;MAS VERSION 5.1;
+3 ;
+4 ;INPUT: DFN = IEN OF PATIENT FILE
+5 ; DFN1 = INVERSE DISPOSTION TIME
EN ;
+1 SET DGLDOUBL=""
SET $PIECE(DGLDOUBL,"=",132)=""
+2 SET DGLSUP=""
SET $PIECE(DGLSUP,"- ",62)=""
SET $PIECE(DGLSUP,"- ",43)=" |"
+3 SET DGLSUP1=""
SET $PIECE(DGLSUP1,"-",123)=""
SET $PIECE(DGLSUP1,"-",86)="|"
+4 FOR I="INE","DIS",0,.15,.24,.361
SET DGP(I)=$GET(^DPT(DFN,I))
+5 SET DGD=$GET(^DPT(DFN,"DIS",DFN1,0))
SET Y=$PIECE(DGD,U,1)
XECUTE ^DD("DD")
SET DGAP=Y
SET DGCLK=$SELECT($DATA(^VA(200,+$PIECE(DGD,U,5),0)):$SELECT($PIECE(^(0),U,2)]"":$PIECE(^(0),U,2)_"/"_$PIECE(DGD,U,5),1:"unk/"_$PIECE(DGD,U,5)),1:"unspecified")
SET DGNAM=$PIECE(DGP(0),U,1)
+6 SET DGSS=$PIECE(DGP(0),U,9)
SET DGSS=$EXTRACT(DGSS,1,3)_"-"_$EXTRACT(DGSS,4,5)_"-"_$EXTRACT(DGSS,6,10)
+7 SET DGLDOUBL=$EXTRACT(DGLDOUBL,1,127)
+8 IF $$FIRST^DGUTL
GOTO Q^DG1010S2
+9 WRITE !?5,DGLDOUBL,!?5
+10 SET X=$$SITE^VASITE
WRITE $SELECT((+X=-1):"FACILITY NOT IDENTIFIED",1:$PIECE(X,U,2)_" ("_$PIECE(X,U,3)_")")
+11 WRITE ?105,"SUPPLEMENTAL DATA SHEET",!?5,DGLDOUBL,!?5,"1. Applicant's Name: ",DGNAM,?90,"| 2. SSN: ",DGSS,!?5,DGLSUP1,!?5,"3. Other Name(s): "
+12 SET I1=""
FOR I=0:0
SET I=$ORDER(^DPT(DFN,.01,I))
IF I'>0
QUIT
SET I1=1
SET DGD=$PIECE(^(I,0),U,1)
SET DGD(1)=$PIECE(^(0),U,2)
SET DGD=DGD_$SELECT($LENGTH(DGD(1)):" ("_$EXTRACT(DGD(1),1,3)_"-"_$EXTRACT(DGD(1),4,5)_"-"_$EXTRACT(DGD(1),6,10)_")",1:"")_"; "
IF (128-$X)<$LENGTH(DGD)
WRITE !?9
WRITE DGD
+13 IF 'I1
WRITE "NO ALIAS' ON FILE"
KILL DGD,I,I1
SET DGD=$SELECT($LENGTH($PIECE(DGP(0),U,10)):$PIECE(DGP(0),U,10),1:"NO REMARKS CURRENTLY ENTERED FOR THIS APPLICANT")
WRITE !?5,DGLSUP1,!?5,"4. Remarks: ",DGD,!?5,DGLSUP1
+14 SET DGD=DGP(.24)
WRITE !?5,"5. Fathers Name: ",$SELECT($LENGTH($PIECE(DGD,U,1)):$PIECE(DGD,U,1),1:"NOT SPECIFIED"),?90,"|"
+15 WRITE !?9,"Mothers Name: ",$SELECT($LENGTH($PIECE(DGD,U,2)):$PIECE(DGD,U,2),1:"NOT SPECIFIED"),?90,"|",!?9,"Mothers Maiden Name: ",$SELECT($LENGTH($PIECE(DGD,U,3)):$PIECE(DGD,U,3),1:"NOT SPECIFIED"),?90,"|",!?5,DGLSUP1
+16 WRITE !?5,"6a. Enrollment Clinic(s): "
SET I1=""
FOR I=0:0
SET I=$ORDER(^DPT(DFN,"DE",I))
IF I'>0
QUIT
IF $PIECE(^(I,0),U,2)'="I"
SET I1=I1+1
SET DGD=$SELECT($DATA(^SC(+^(0),0)):$PIECE(^(0),U,1)_", ",1:"")
IF (128-$X)<$LENGTH(DGD)
WRITE !?9
WRITE DGD
+17 IF 'I1
WRITE "NOT ACTIVELY ENROLLED IN ANY CLINICS AT THIS TIME"
KILL DGD,I,I1
WRITE !?5,DGLSUP,!?5,"6b. Future Appointments: "
SET I1=""
SET I2=DT_".9999"
+18 FOR J=0:0
SET I2=$ORDER(^DPT(DFN,"S",I2))
IF I2=""
QUIT
IF $SELECT($PIECE(^(I2,0),U,2)']"":1,$PIECE(^(0),U,2)="I":1,1:0)
SET DGD(1)=+$PIECE(^(0),U,1)
SET Y=I2
XECUTE ^DD("DD")
SET DGD=$SELECT($DATA(^SC(+DGD(1),0)):$PIECE(^(0),U,1),1:"UNKNOWN")_" ("_Y_"), "
SET I1=1
IF (128-$X)<$LENGTH(DGD)
WRITE !?9
WRITE DGD
+19 IF 'I1
WRITE "NO PENDING APPOINTMENTS ON FILE"
WRITE !?5,DGLSUP1,!?5,"7a. Last Admission: "
+20 SET DGAD=$SELECT('$DATA(^DPT(DFN,.1)):0,'$LENGTH(^DPT(DFN,.1)):0,1:1)
SET DGD=$ORDER(^DGPM("ATID1",DFN,+$SELECT(DGAD:$ORDER(^DGPM("ATID1",DFN,0)),1:0)))
IF DGD'>0
WRITE "NO PREVIOUS ADMISSIONS TO THIS FACILITY ON FILE"
GOTO EL
+21 SET DGD=$ORDER(^DGPM("ATID1",DFN,DGD,0))
IF $SELECT('$DATA(^DGPM(+DGD,0)):1,'$DATA(^DGPT(+$PIECE(^(0),"^",16),0)):1,1:0)
WRITE "LAST ADMISSION PTF DATA NO LONGER STORED"
GOTO EL
+22 SET DGD=+$PIECE(^DGPM(+DGD,0),"^",16)
SET Y=+^(0)
+23 XECUTE ^DD("DD")
WRITE Y
SET Y=$PIECE($SELECT($DATA(^DGPT(DGD,70)):^(70),1:0),U,1)
XECUTE ^DD("DD")
IF Y]""
WRITE " (DISCHARGED '"_Y_"')"
WRITE !?5,DGLSUP,!?5,"7b. Discharge Diagnosis(es): "
SET I1=$SELECT($DATA(^DGPT(DGD,"M",1,0)):^(0),1:0)
+24 SET I3=""
FOR I=5:1:15
IF I'=10
SET I2=$PIECE(I1,U,I)
IF 'I2
QUIT
SET I3=1
SET I2=$SELECT($DATA(^ICD9(I2,0)):"("_$PIECE(^(0),U,1)_")-"_$PIECE(^(0),U,3)_"; ",1:"")
IF (128-$X)<$LENGTH(I2)
WRITE !?9
WRITE I2
+25 IF 'I3
WRITE "NO DIAGNOSES ON FILE FOR THIS ADMISSION PERIOD YET",!?5,DGLSUP
SET DGD(1)=$SELECT($DATA(^DGPT(DGD,70)):^(70),1:0)
SET X="UNSPECIFIED"
SET X=$SELECT('DGD(1):X,$DATA(^ICD9(+$PIECE(DGD(1),U,11),0)):"("_$PIECE(^(0),U,1)_")-"_$PIECE(^(0),U,3),1:X)
+26 WRITE !?5,"7c. Admit Diagnosis: ",X,!?5,DGLSUP,!?5,"7d. Diagnosis Responsible for Greatest Length of Stay: "
SET X="UNSPECIFIED"
SET X=$SELECT('DGD(1):X,$DATA(^ICD9(+$PIECE(DGD(1),U,10),0)):"("_$PIECE(^(0),U,1)_")-"_$PIECE(^(0),U,3),1:X)
WRITE X
EL WRITE !?5,DGLSUP1
SET DGD=DGP(.361)
SET DGD(1)=$PIECE(DGD,U,5)
SET DGD(2)=$PIECE(DGD,U,6)
SET Y=$PIECE(DGD,U,2)
SET DGD=$PIECE(DGD,U,1)
SET DGD(1)=$SELECT($LENGTH(DGD(1)):DGD(1),'$LENGTH(DGD):"NOT APPLICABLE",1:"NOT VERIFIED")
+1 SET DGD(2)=$SELECT(+DGD(2):$SELECT($DATA(^VA(200,+DGD(2),0)):$PIECE(^(0),U,1),1:"UNKNOWN"),'$LENGTH(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED")
IF +Y
XECUTE ^DD("DD")
SET Y=$SELECT($LENGTH(Y):Y,'$LENGTH(DGD):"NOT APPLICABLE",1:"NOT SPECIFIED")
+2 WRITE !?5,"8. Eligibility Status: ",$SELECT(DGD="P":"PENDING VERIFICATION",DGD="R":"PENDING RE-VERIFICATION",DGD="V":"VERIFIED",1:"UNKNOWN OR NONE"),?90,"| Status Date: ",Y,!?9,"Verification Method: ",DGD(1),?90,"| By: ",DGD(2)
+3 SET Y=$PIECE(DGP(.15),U,2)
SET DGD=DGP("INE")
IF +Y
XECUTE ^DD("DD")
SET DGEL=$SELECT('$LENGTH(Y)!(Y=0):1,1:0)
SET Y=$SELECT('DGEL:Y,1:"ELIGIBLE APPLICANT -- NOT APPLICABLE")
WRITE !?9,"Ineligible Date: ",Y
IF DGEL
FOR I=1:1:4
SET DGD(I)="NOT APPLICABLE"
+4 IF DGEL
GOTO C
SET DGD(1)=$PIECE(DGD,U,1)
SET DGD(1)=$SELECT(DGD(1)=1:"VAMC",DGD(1)=2:"REGIONAL OFFICE",DGD(2)=3:"RPC",1:"UNKNOWN")
SET DGD(2)=$SELECT($LENGTH($PIECE(DGD,U,3)):$PIECE(DGD,U,3),1:"CITY UNKNOWN")
SET DGD(3)=$SELECT($DATA(^DIC(5,+$PIECE(DGD,U,4),0)):$PIECE(^(0),U,1),1:"STATE UNKNOWN")
+5 SET DGD(4)=$SELECT($PIECE(DGD,U,6)]"":$PIECE(DGD,U,6),1:"VARO DECISION UNKNOWN")
C WRITE ?90,"| TWX Source: ",DGD(1),!?9,"TWX City: ",DGD(2),?90,"| TWX State: ",$EXTRACT(DGD(3),1,26),!?9,"VARO Decision: ",DGD(4),!?5,DGLSUP1
+1 KILL DGAD,DGD,DGEL,I,I1,I2,Y
GOTO ^DG1010S2
