DGPTF1.m

DGPTF1 ;ALB/JDS - PTF ENTRY/EDIT ; 5/17/05 3:29pm

 ;;5.3;PIMS;**69,114,195,397,342,415,1015,1016**;JUN 30, 2012;Build 20

 ;

 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 I $D(DGCST) W !?40,"Census Status: ",$P($P($P(^DD(45,6,0),"^",3),+DGCST_":",2),";")

 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: " S L=";"_$P(^DD(45,22,0),U,3),L1=";"_$P(B(101),U,3)_":" W $P($P(L,L1,2),";",1)

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(B(101),U,8):$P($G(^DIC(8,+$P(B(101),U,8),0)),U),1:"UNKNOWN") W ?50,"SCI: " S L=";"_$P(^DD(2,57.4,0),U,3),L1=";"_$P(A(57),U,4)_":" W $P($P(L,L1,2),";",1)

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

 ;

 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

DGPTF1    ;ALB/JDS - PTF ENTRY/EDIT ; 5/17/05 3:29pm

 +1       ;;5.3;PIMS;**69,114,195,397,342,415,1015,1016**;JUN 30, 2012;Build 20

 +2       ;

 +3        IF '$DATA(IOF)

               SET IOP="HOME"

               DO ^%ZIS

               KILL IOP

 +4        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        IF $DATA(DGCST)

               WRITE !?40,"Census Status: ",$PIECE($PIECE($PIECE(^DD(45,6,0),"^",3),+DGCST_":",2),";")

 +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: "

           SET L=";"_$PIECE(^DD(45,22,0),U,3)

           SET L1=";"_$PIECE(B(101),U,3)_":"

           WRITE $PIECE($PIECE(L,L1,2),";",1)

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(B(101),U,8):$PIECE($GET(^DIC(8,+$PIECE(B(101),U,8),0)),U),1:"UNKNOWN")

           WRITE ?50,"SCI: "

           SET L=";"_$PIECE(^DD(2,57.4,0),U,3)

           SET L1=";"_$PIECE(A(57),U,4)_":"

           WRITE $PIECE($PIECE(L,L1,2),";",1)

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        DO EN^DGPTF4

           KILL A,B

           IF DGPR

               QUIT 

 +5       ;

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