DGPTF1 ;ALB/JDS/PLT - PTF ENTRY/EDIT ;04/01/24 3:29pm
;;5.3;Registration;**69,114,195,397,342,415,565,664,884,1095,1104**;Aug 13, 1993;Build 59
;;Per VA Directive 6402, this routine should not be modified.
;
I '$D(IOF) S IOP="HOME" D ^%ZIS K IOP
S:'$D(IOST) IOST="C" S DGVI="""""",DGVO=DGVI I $D(IOST(0)) S:$D(^%ZIS(2,IOST(0),5)) I=^(5) S:$L($P(I,U,4)) DGVI=$P(I,U,4) S:$L($P(I,U,5)) DGVO=$P(I,U,5) I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
WR G GET:'$D(A)!('$D(B)) W @IOF,HEAD,?72,@DGVI,"<101>",@DGVO
FAC W ! I $D(DGCST) S:$G(DGCN) X=$G(^DG(45.86,DGCN,0)) W ?37,"Census " W:$G(DGCN) "Date: ",$E(X,4,5),"/",$E(X,6,7),"/",$E(X,2,3)," " W "Status: ",$$EXTERNAL^DILFD(45,6,,+DGCST)
W ! S Z=1 D Z W " Facility: " S Z=$P(B(0),U,3)_$P(B(0),U,5),Z1=23 D Z1
MAR S Z=2 D Z W " Marit Stat: ",$S($D(^DIC(11,+$P(A(0),U,5),0)):$P(^(0),U,1),1:"")
SA W !," Source of Adm: ",$S($D(^DIC(45.1,+B(101),0)):$P(^(0),U,5),1:"")
N VADM D DEM^VADPT
W ?39,"Ethnic: " D
.I 'VADM(11) W "" Q
.N NODE,NUM,ETHNIC,I
.S I=0
.F NUM=0:1 S I=+$O(VADM(11,I)) Q:'I D
..S X=$$PTR2CODE^DGUTL4(+VADM(11,I),2,4)
..S ETHNIC=$S(X="":"?",1:X)
..S X=$$PTR2CODE^DGUTL4(+$G(VADM(11,I,1)),3,4)
..S ETHNIC=ETHNIC_$S(X="":"?",1:X)
..I NUM S ETHNIC=","_ETHNIC
..W ETHNIC
W ?55,"Race: " D
.I 'VADM(12) W "" Q
.N NODE,NUM,RACE,I
.S I=0
.F NUM=0:1 S I=+$O(VADM(12,I)) Q:'I D
..S X=$$PTR2CODE^DGUTL4(+VADM(12,I),1,4)
..S RACE=$S(X="":"?",1:X)
..S X=$$PTR2CODE^DGUTL4(+$G(VADM(12,I,1)),3,4)
..S RACE=RACE_$S(X="":"?",1:X)
..I NUM S RACE=","_RACE
..W RACE
K VADM
W !," Source of Pay: ",$$EXTERNAL^DILFD(45,22,,$P(B(101),U,3))
SEX S SEX=$P(A(0),U,2) W ?39," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:"")
W !,"Trans Facility: ",$P(B(101),U,5)_$P(B(101),U,6)
DOB S DOB=$P(A(0),U,3),Y=DOB D D^DGPTUTL W ?39," Date of Birth: ",Y
CAT I DGPTFMT<2 W !," Cat of Ben: ",$S($D(^DIC(45.82,+$P(B(101),U,4),0)):$E($P(^(0),U,2),1,26),1:"")
W:$X>50 !
W " Admit Elig: "_$S($P($G(^DIC(8,+$P(B(101),U,8),0)),U)="COMPACT ACT ELIGIBLE":"COMPACT ACT",+$P(B(101),U,8):$P($G(^DIC(8,+$P(B(101),U,8),0)),U),1:"UNKNOWN") W ?50,"SCI: ",$$EXTERNAL^DILFD(2,57.4,,$P(A(57),U,4))
VIET W ! S Z=3 D Z W "Vietnam SRV: " S L=$P(A(.321),U,1),Z=$S(L="Y":"YES",L="N":"NO",1:"UNKNOWN"),Z1=27 D Z1
ST S Z=4 D Z W $S('$$FORIEN^DGADDUTL($P(A(.11),U,10))!('$P(A(.11),U,10)):" State: "_$S($D(^DIC(5,+$P(A(.11),U,5),0)):$P(^(0),U,1),1:""),1:"Country: "_$$CNTRYI^DGADDUTL($P(A(.11),U,10)))
POW W !?11,"POW: " S L=$P(A(.52),U,5) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
ZIP W ?42,$S('$$FORIEN^DGADDUTL($P(A(.11),U,10))!('$P(A(.11),U,10)):" Zip Code: "_$P(A(.11),U,6),1:"Postal Code: "_$P(A(.11),U,9))
POS W !,?6," POW SRV: " S L=$P(A(.52),U,6) W $E($S($D(^DIC(22,+L,0)):$P(^(0),U,1),1:""),1,23)
COU W ?45,$S('$$FORIEN^DGADDUTL($P(A(.11),U,10))!('$P(A(.11),U,10)):" County: "_$S($D(^DIC(5,+$P(A(.11),U,5),1,+$P(A(.11),U,7),0)):$P(^(0),U,1),1:""),1:"Province: "_$P(A(.11),U,8))
ION W !," Ion Rad Exp: " S L=$P(A(.321),U,3) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
METH S L=$P(A(.321),U,12) W:L'="" ?38,"Exposure Method: ",$S(L="N":"Nagasaki/Hiroshima",L="T":"Nuclear Testing",L="B":"Both",1:"")
AO W !," AO Exp/Loc: " S L=$P(A(.321),U,2) W $S(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
S L=$P(A(.321),U,13) W:L'="" $S(L="V":"/VIET",L="K":"/DMZ",L="O":"/OTHER",1:"")
SHAD W ?40,"PROJ 112/SHAD: ",$S(A("SHAD")=1:"YES",1:"NO")
MST W !," Claims MST: " S L=$P(A("MST"),U) W $S(L="Y":"YES",L="N":"NO",L="D":"DECLINED TO ANSWER",1:"UNKNOWN") ; added 6/17/98 for MST enhancement
NTR W ?39," N/T Radium: " S L=A("NTR") W $E($S(L'="":L,1:"UNKNOWN"),1,25)
CV S L=$S($P(A("CV"),U,1)>0:1,1:0)
W !,"Combat Veteran: ",$S(L:"YES",1:"NO")
I L S Y=$P(A("CV"),U,2) D D^DGPTUTL W ?45,"End Date: ",Y
;
N ELIG S ELIG=$$ELIG^DGCOMPACTELIG(DFN,"DGPTF1")
W !,"Acute Suicidal Crisis: ",$S($P($G(^DGPT(PTF,70)),"^",33)=1:"YES",$P($G(^DGPT(PTF,70)),"^",33)=0:"NO",1:"")," COMPACT Act: ",ELIG
D EN^DGPTF4 K A,B Q:DGPR
;
JUMP F I=$Y:1:20 W !
G 101^DGPTFJC:DGN S (DGZM0,DGZS0)=0
R "Enter: <RET> for <MAS>,",!,"1-7 to edit,'^N' for screen N, or '^' to abort: <MAS>// ",X:DTIME S:'$T X="^",DGPTOUT=""
G ^DGPTFM:X="",Q:X="^"
I X?1"^".E S DGPTSCRN=101 G ^DGPTFJ
G PR:X?.N&($L(X)>2)
I X["-" S K=X,X="" F I=1:1 S J=$P(K,",",I) Q:J']"" I +J<8 S:J'["-" X=X_J_"," I J["-"&(+J) I +J<+$P(J,"-",2) F L=+J:1:+$P(J,"-",2) S:L<8 X=X_L_","
I X'[",",1234567'[X G PR
F I=1:1 S J=$P(X,",",I) Q:'J G:J<1!(J>7)!(J'?1N) PR
I X<1!(X>7) G PR
S (PT(1),PT(2))="",DGJUMP=X,DA=PTF,DIE="^DGPT(",DR="[DG101"_$E("F",DGPTFE)_"]" D ^DIE
;--
N DGPMCA,DGPMAN D PM^DGPTUTL
I '$G(DGADM) S DGADM=+^DGPT(PTF,0)
D MT^DGPTUTL
GET F I=.32,.52,57,.521,0,.321,.11,.3 S A(I)="" S:$D(^DPT(DFN,I))&('DGST) A(I)=^(I) I DGN S:$D(^DGP(45.84,PTF,$S('I:10,1:I))) A(I)=^($S('I:10,1:I))
; The following line added for MST enhancement 4/21/99
S A("MST")=$P($$GETSTAT^DGMSTAPI(DFN),U,2,5)
K DGNTARR
S A("NTR")=$S($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
K DGNTARR
F I=0,101,70 S B(I)="" S:$D(^DGPT(PTF,I)) B(I)=^(I)
S DGDD=+B(70),DGFC=+$P(B(0),U,3)
S A("CV")=$$CVEDT^DGCV(DFN,$P($G(B(0)),U,2))
S A("SHAD")=$$GETSHAD^DGUTL3(DFN)
K PT G DGPTF1
PR W !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (screen # appears in upper right of screen '<N>')",!,"<RET> to continue on to the next screen or 1-7 to edit:"
W !?10,"1-Facility, Source of admis, Payment, Transf facil, and Cat. of Benef",!?10,"2-Marital Stat, Race, Ethnicity, Sex, SCI, DOB"
W !?10,"3-Agent Orange, Prisoner of War, Ionizing Radiation, MST, N/T Radium",!?10,"4-State, County, Zip code"
W !?10,"5-Discharge date, type & specialty",!?10,"6-Outpatient treat & VA Auspices",!?10,"7-Receiving Facility, ASIH Days & C&P Status"
W !,"You may also enter any combination of the above, separated by commas(ex:1,3,5)",!
R !!,"Enter <RET> : ",X:DTIME G WR
Q G Q^DGPTF
Q
Z I 'DGN S Z=$S(IOST="C-QUME"&($L(DGVI)'=2):Z,1:"["_Z_"]") W @DGVI,Z,@DGVO
E W " "
Q
Z1 F I=1:1:(Z1-$L(Z)) S Z=Z_" "
W Z
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTF1 6131 printed Sep 23, 2025@20:27:55 Page 2
DGPTF1 ;ALB/JDS/PLT - PTF ENTRY/EDIT ;04/01/24 3:29pm
+1 ;;5.3;Registration;**69,114,195,397,342,415,565,664,884,1095,1104**;Aug 13, 1993;Build 59
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 IF '$DATA(IOF)
SET IOP="HOME"
DO ^%ZIS
KILL IOP
+5 if '$DATA(IOST)
SET IOST="C"
SET DGVI=""""""
SET DGVO=DGVI
IF $DATA(IOST(0))
if $DATA(^%ZIS(2,IOST(0),5))
SET I=^(5)
if $LENGTH($PIECE(I,U,4))
SET DGVI=$PIECE(I,U,4)
if $LENGTH($PIECE(I,U,5))
SET DGVO=$PIECE(I,U,5)
IF $LENGTH(DGVI_DGVO)>4
SET X=132
XECUTE ^%ZOSF("RM")
WR if '$DATA(A)!('$DATA(B))
GOTO GET
WRITE @IOF,HEAD,?72,@DGVI,"<101>",@DGVO
FAC WRITE !
IF $DATA(DGCST)
if $GET(DGCN)
SET X=$GET(^DG(45.86,DGCN,0))
WRITE ?37,"Census "
if $GET(DGCN)
WRITE "Date: ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",$EXTRACT(X,2,3)," "
WRITE "Status: ",$$EXTERNAL^DILFD(45,6,,+DGCST)
+1 WRITE !
SET Z=1
DO Z
WRITE " Facility: "
SET Z=$PIECE(B(0),U,3)_$PIECE(B(0),U,5)
SET Z1=23
DO Z1
MAR SET Z=2
DO Z
WRITE " Marit Stat: ",$SELECT($DATA(^DIC(11,+$PIECE(A(0),U,5),0)):$PIECE(^(0),U,1),1:"")
SA WRITE !," Source of Adm: ",$SELECT($DATA(^DIC(45.1,+B(101),0)):$PIECE(^(0),U,5),1:"")
+1 NEW VADM
DO DEM^VADPT
+2 WRITE ?39,"Ethnic: "
Begin DoDot:1
+3 IF 'VADM(11)
WRITE ""
QUIT
+4 NEW NODE,NUM,ETHNIC,I
+5 SET I=0
+6 FOR NUM=0:1
SET I=+$ORDER(VADM(11,I))
if 'I
QUIT
Begin DoDot:2
+7 SET X=$$PTR2CODE^DGUTL4(+VADM(11,I),2,4)
+8 SET ETHNIC=$SELECT(X="":"?",1:X)
+9 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(11,I,1)),3,4)
+10 SET ETHNIC=ETHNIC_$SELECT(X="":"?",1:X)
+11 IF NUM
SET ETHNIC=","_ETHNIC
+12 WRITE ETHNIC
End DoDot:2
End DoDot:1
+13 WRITE ?55,"Race: "
Begin DoDot:1
+14 IF 'VADM(12)
WRITE ""
QUIT
+15 NEW NODE,NUM,RACE,I
+16 SET I=0
+17 FOR NUM=0:1
SET I=+$ORDER(VADM(12,I))
if 'I
QUIT
Begin DoDot:2
+18 SET X=$$PTR2CODE^DGUTL4(+VADM(12,I),1,4)
+19 SET RACE=$SELECT(X="":"?",1:X)
+20 SET X=$$PTR2CODE^DGUTL4(+$GET(VADM(12,I,1)),3,4)
+21 SET RACE=RACE_$SELECT(X="":"?",1:X)
+22 IF NUM
SET RACE=","_RACE
+23 WRITE RACE
End DoDot:2
End DoDot:1
+24 KILL VADM
+25 WRITE !," Source of Pay: ",$$EXTERNAL^DILFD(45,22,,$PIECE(B(101),U,3))
SEX SET SEX=$PIECE(A(0),U,2)
WRITE ?39," Sex: ",$SELECT(SEX="M":"MALE",SEX="F":"FEMALE",1:"")
+1 WRITE !,"Trans Facility: ",$PIECE(B(101),U,5)_$PIECE(B(101),U,6)
DOB SET DOB=$PIECE(A(0),U,3)
SET Y=DOB
DO D^DGPTUTL
WRITE ?39," Date of Birth: ",Y
CAT IF DGPTFMT<2
WRITE !," Cat of Ben: ",$SELECT($DATA(^DIC(45.82,+$PIECE(B(101),U,4),0)):$EXTRACT($PIECE(^(0),U,2),1,26),1:"")
+1 if $X>50
WRITE !
+2 WRITE " Admit Elig: "_$SELECT($PIECE($GET(^DIC(8,+$PIECE(B(101),U,8),0)),U)="COMPACT ACT ELIGIBLE":"COMPACT ACT",+$PIECE(B(101),U,8):$PIECE($GET(^DIC(8,+$PIECE(B(101),U,8),0)),U),1:"UNKNOWN")
WRITE ?50,"SCI: ",$$EXTERNAL^DILFD(2,57.4,,$PIECE(A(57),U,4))
VIET WRITE !
SET Z=3
DO Z
WRITE "Vietnam SRV: "
SET L=$PIECE(A(.321),U,1)
SET Z=$SELECT(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
SET Z1=27
DO Z1
ST SET Z=4
DO Z
WRITE $SELECT('$$FORIEN^DGADDUTL($PIECE(A(.11),U,10))!('$PIECE(A(.11),U,10)):" State: "_$SELECT($DATA(^DIC(5,+$PIECE(A(.11),U,5),0)):$PIECE(^(0),U,1),1:""),1:"Country: "_$$CNTRYI^DGADDUTL($PIECE(A(.11),U,10)))
POW WRITE !?11,"POW: "
SET L=$PIECE(A(.52),U,5)
WRITE $SELECT(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
ZIP WRITE ?42,$SELECT('$$FORIEN^DGADDUTL($PIECE(A(.11),U,10))!('$PIECE(A(.11),U,10)):" Zip Code: "_$PIECE(A(.11),U,6),1:"Postal Code: "_$PIECE(A(.11),U,9))
POS WRITE !,?6," POW SRV: "
SET L=$PIECE(A(.52),U,6)
WRITE $EXTRACT($SELECT($DATA(^DIC(22,+L,0)):$PIECE(^(0),U,1),1:""),1,23)
COU WRITE ?45,$SELECT('$$FORIEN^DGADDUTL($PIECE(A(.11),U,10))!('$PIECE(A(.11),U,10)):" County: "_$SELECT($DATA(^DIC(5,+$PIECE(A(.11),U,5),1,+$PIECE(A(.11),U,7),0)):$PIECE(^(0),U,1),1:""),1:"Province: "_$PIECE(A(.11),U,8))
ION WRITE !," Ion Rad Exp: "
SET L=$PIECE(A(.321),U,3)
WRITE $SELECT(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
METH SET L=$PIECE(A(.321),U,12)
if L'=""
WRITE ?38,"Exposure Method: ",$SELECT(L="N":"Nagasaki/Hiroshima",L="T":"Nuclear Testing",L="B":"Both",1:"")
AO WRITE !," AO Exp/Loc: "
SET L=$PIECE(A(.321),U,2)
WRITE $SELECT(L="Y":"YES",L="N":"NO",1:"UNKNOWN")
+1 SET L=$PIECE(A(.321),U,13)
if L'=""
WRITE $SELECT(L="V":"/VIET",L="K":"/DMZ",L="O":"/OTHER",1:"")
SHAD WRITE ?40,"PROJ 112/SHAD: ",$SELECT(A("SHAD")=1:"YES",1:"NO")
MST ; added 6/17/98 for MST enhancement
WRITE !," Claims MST: "
SET L=$PIECE(A("MST"),U)
WRITE $SELECT(L="Y":"YES",L="N":"NO",L="D":"DECLINED TO ANSWER",1:"UNKNOWN")
NTR WRITE ?39," N/T Radium: "
SET L=A("NTR")
WRITE $EXTRACT($SELECT(L'="":L,1:"UNKNOWN"),1,25)
CV SET L=$SELECT($PIECE(A("CV"),U,1)>0:1,1:0)
+1 WRITE !,"Combat Veteran: ",$SELECT(L:"YES",1:"NO")
+2 IF L
SET Y=$PIECE(A("CV"),U,2)
DO D^DGPTUTL
WRITE ?45,"End Date: ",Y
+3 ;
+4 NEW ELIG
SET ELIG=$$ELIG^DGCOMPACTELIG(DFN,"DGPTF1")
+5 WRITE !,"Acute Suicidal Crisis: ",$SELECT($PIECE($GET(^DGPT(PTF,70)),"^",33)=1:"YES",$PIECE($GET(^DGPT(PTF,70)),"^",33)=0:"NO",1:"")," COMPACT Act: ",ELIG
+6 DO EN^DGPTF4
KILL A,B
if DGPR
QUIT
+7 ;
JUMP FOR I=$Y:1:20
WRITE !
+1 if DGN
GOTO 101^DGPTFJC
SET (DGZM0,DGZS0)=0
+2 READ "Enter: <RET> for <MAS>,",!,"1-7 to edit,'^N' for screen N, or '^' to abort: <MAS>// ",X:DTIME
if '$TEST
SET X="^"
SET DGPTOUT=""
+3 if X=""
GOTO ^DGPTFM
if X="^"
GOTO Q
+4 IF X?1"^".E
SET DGPTSCRN=101
GOTO ^DGPTFJ
+5 if X?.N&($LENGTH(X)>2)
GOTO PR
+6 IF X["-"
SET K=X
SET X=""
FOR I=1:1
SET J=$PIECE(K,",",I)
if J']""
QUIT
IF +J<8
if J'["-"
SET X=X_J_","
IF J["-"&(+J)
IF +J<+$PIECE(J,"-",2)
FOR L=+J:1:+$PIECE(J,"-",2)
if L<8
SET X=X_L_","
+7 IF X'[","
IF 1234567'[X
GOTO PR
+8 FOR I=1:1
SET J=$PIECE(X,",",I)
if 'J
QUIT
if J<1!(J>7)!(J'?1N)
GOTO PR
+9 IF X<1!(X>7)
GOTO PR
+10 SET (PT(1),PT(2))=""
SET DGJUMP=X
SET DA=PTF
SET DIE="^DGPT("
SET DR="[DG101"_$EXTRACT("F",DGPTFE)_"]"
DO ^DIE
+11 ;--
+12 NEW DGPMCA,DGPMAN
DO PM^DGPTUTL
+13 IF '$GET(DGADM)
SET DGADM=+^DGPT(PTF,0)
+14 DO MT^DGPTUTL
GET FOR I=.32,.52,57,.521,0,.321,.11,.3
SET A(I)=""
if $DATA(^DPT(DFN,I))&('DGST)
SET A(I)=^(I)
IF DGN
if $DATA(^DGP(45.84,PTF,$SELECT('I
SET A(I)=^($SELECT('I:10,1:I))
+1 ; The following line added for MST enhancement 4/21/99
+2 SET A("MST")=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2,5)
+3 KILL DGNTARR
+4 SET A("NTR")=$SELECT($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
+5 KILL DGNTARR
+6 FOR I=0,101,70
SET B(I)=""
if $DATA(^DGPT(PTF,I))
SET B(I)=^(I)
+7 SET DGDD=+B(70)
SET DGFC=+$PIECE(B(0),U,3)
+8 SET A("CV")=$$CVEDT^DGCV(DFN,$PIECE($GET(B(0)),U,2))
+9 SET A("SHAD")=$$GETSHAD^DGUTL3(DFN)
+10 KILL PT
GOTO DGPTF1
PR WRITE !,"Enter '^' to stop the display and edit of data",!,"'^N' to jump to screen #N (screen # appears in upper right of screen '<N>')",!,"<RET> to continue on to the next screen or 1-7 to edit:"
+1 WRITE !?10,"1-Facility, Source of admis, Payment, Transf facil, and Cat. of Benef",!?10,"2-Marital Stat, Race, Ethnicity, Sex, SCI, DOB"
+2 WRITE !?10,"3-Agent Orange, Prisoner of War, Ionizing Radiation, MST, N/T Radium",!?10,"4-State, County, Zip code"
+3 WRITE !?10,"5-Discharge date, type & specialty",!?10,"6-Outpatient treat & VA Auspices",!?10,"7-Receiving Facility, ASIH Days & C&P Status"
+4 WRITE !,"You may also enter any combination of the above, separated by commas(ex:1,3,5)",!
+5 READ !!,"Enter <RET> : ",X:DTIME
GOTO WR
Q GOTO Q^DGPTF
+1 QUIT
Z IF 'DGN
SET Z=$SELECT(IOST="C-QUME"&($LENGTH(DGVI)'=2):Z,1:"["_Z_"]")
WRITE @DGVI,Z,@DGVO
+1 IF '$TEST
WRITE " "
+2 QUIT
Z1 FOR I=1:1:(Z1-$LENGTH(Z))
SET Z=Z_" "
+1 WRITE Z
+2 QUIT
