Routine: DGPTFJ

DGPTFJ ;ALB/MRL - JUMP BETWEEN PTF SCREENS ; 12/12/06 9:04am

 ;;5.3;Registration;**58,517,635,729**;Aug 13, 1993;Build 59

TEST K S,M G Q^DGPTF:X="^" S Z="^101^401^501^601^701^801^MAS^CDR",X1=X,X=$P($E(X,2,99),"-",1) G QUES:X1?1"^?".E Q:X=""  D IN^DGHELP G QUES:%=-1

 S Z=$T(@X) I Z="" W !!,"*** Undefined screen number. Valid screens are: ",! G QUES

 I X=4!(X=5) S @($S(+X=5:"DGZM0",1:"DGZS0"))=$S(X1["-":+$P(X1,"-",2),1:1)

 I X=6 S DGZP=$S(X1["-":+$P(X1,"-",2),1:1)

 I X=8 S ANS="F"_$P(X1,"-",2)

 K M,L1,T G @($P(Z,";",3))

HELP W !!,"PTF Screens are: ",! F I=1,5,4,6,7,8,"M","C" S T=$T(@I) Q:T=""  W !?5,I,?10,$P(T,";",4)

QUES D HELP W !!,"Press Return to continue: " R X:4

 I $D(DGPTSCRN) S Z=$P($T(@$E(DGPTSCRN)),";",3) K DGPTSCRN G:Z]"" @Z

 G WR^DGPTF1

Q G Q^DGPTF

PROG ;

1 ;;WR^DGPTF1;'101' Screen--Admission/disposition Transaction

5 ;;EN^DGPTFM4;'501' Screen--Patient movement transaction

4 ;;EN^DGPTFM5;'401' Screen--Surgical/procedure entry

6 ;;E^DGPTFM1;'601' Screen--Procedure entry (AVAILABLE FOR DISCHARGES AFTER 10/1/87)

7 ;;EN1^DGPTF4;'701' Screen--PDXLS/DRG print

8 ;;F^DGPTFM2;'801' Screen--CPT entry (CPT and HCPCS)

M ;;^DGPTFM;'MAS' screen--surgery/procedure/diagnosis code edits

C ;;EN^DGPTFM7;'MPCR' screen--displays MPCR information

SA ;called from input transform on SOURCE OF ADMISSION field (#20) PTF file (#45)

 S DGER=$S('$D(PTF):1,'$D(^DGPT(PTF,0)):1,1:0) Q:DGER!("^48^49^50^"'[(U_Y_U))  S DGSU1=$P(^(0),"^",5),DGSU0=$S($D(^DGPT(PTF,101)):$P(^(101),"^",6),1:"")

 S DGSTATYP=$S(Y=48:11,Y=49:40,Y=50:30)

 D NUMACT^DGPTSUF(DGSTATYP)

 I DGANUM>0 D

 .I Y=48 F I=1:1:DGANUM S DGER=$S(((DGSU1=DGSUFNAM(DGANUM))!(DGSU1=""))&((DGSU0=DGSUFNAM(DGANUM))!(DGSU0="")):0,1:1)

 .I Y=49!(Y=50) F I=1:1:DGANUM S DGER=$S((Y=49&(DGSU1=DGSUFNAM(DGANUM))&("^9AA^9AB^9AC^9AD^9AE^"[(U_DGSU0_U))):0,(Y=50&(DGSU1=DGSUFNAM(DGANUM))&("^BU^BV^BW^BX^"[(U_DGSU0_U))):0,1:1)

 K DGANUM,DGSTATYP,DGSUFNAM,I

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFJ   1955     printed  Feb 19, 2025@00:18:15                                                                                                                                                                                                      Page 2

DGPTFJ    ;ALB/MRL - JUMP BETWEEN PTF SCREENS ; 12/12/06 9:04am

 +1       ;;5.3;Registration;**58,517,635,729**;Aug 13, 1993;Build 59

 +2       ;

TEST       KILL S,M

           if X="^"

               GOTO Q^DGPTF

           SET Z="^101^401^501^601^701^801^MAS^CDR"

           SET X1=X

           SET X=$PIECE($EXTRACT(X,2,99),"-",1)

           if X1?1"^?".E

               GOTO QUES

           if X=""

               QUIT

           DO IN^DGHELP

           if %=-1

               GOTO QUES

 +1        SET Z=$TEXT(@X)

           IF Z=""

               WRITE !!,"*** Undefined screen number. Valid screens are: ",!

               GOTO QUES

 +2        IF X=4!(X=5)

               SET @($SELECT(+X=5:"DGZM0",1:"DGZS0"))=$SELECT(X1["-":+$PIECE(X1,"-",2),1:1)

 +3        IF X=6

               SET DGZP=$SELECT(X1["-":+$PIECE(X1,"-",2),1:1)

 +4        IF X=8

               SET ANS="F"_$PIECE(X1,"-",2)

 +5        KILL M,L1,T

           GOTO @($PIECE(Z,";",3))

 +6       ;

HELP       WRITE !!,"PTF Screens are: ",!

           FOR I=1,5,4,6,7,8,"M","C"

               SET T=$TEXT(@I)

               if T=""

                   QUIT

               WRITE !?5,I,?10,$PIECE(T,";",4)

 +1        QUIT

QUES       DO HELP

           WRITE !!,"Press Return to continue: "

           READ X:4

 +1        IF $DATA(DGPTSCRN)

               SET Z=$PIECE($TEXT(@$EXTRACT(DGPTSCRN)),";",3)

               KILL DGPTSCRN

               if Z]""

                   GOTO @Z

 +2        GOTO WR^DGPTF1

Q          GOTO Q^DGPTF

 +1       ;

PROG      ;

1         ;;WR^DGPTF1;'101' Screen--Admission/disposition Transaction

5         ;;EN^DGPTFM4;'501' Screen--Patient movement transaction

4         ;;EN^DGPTFM5;'401' Screen--Surgical/procedure entry

6         ;;E^DGPTFM1;'601' Screen--Procedure entry (AVAILABLE FOR DISCHARGES AFTER 10/1/87)

7         ;;EN1^DGPTF4;'701' Screen--PDXLS/DRG print

8         ;;F^DGPTFM2;'801' Screen--CPT entry (CPT and HCPCS)

M         ;;^DGPTFM;'MAS' screen--surgery/procedure/diagnosis code edits

C         ;;EN^DGPTFM7;'MPCR' screen--displays MPCR information

 +1        QUIT

SA        ;called from input transform on SOURCE OF ADMISSION field (#20) PTF file (#45)

 +1        SET DGER=$SELECT('$DATA(PTF):1,'$DATA(^DGPT(PTF,0)):1,1:0)

           if DGER!("^48^49^50^"'[(U_Y_U))

               QUIT

           SET DGSU1=$PIECE(^(0),"^",5)

           SET DGSU0=$SELECT($DATA(^DGPT(PTF,101)):$PIECE(^(101),"^",6),1:"")

 +2        SET DGSTATYP=$SELECT(Y=48:11,Y=49:40,Y=50:30)

 +3        DO NUMACT^DGPTSUF(DGSTATYP)

 +4        IF DGANUM>0

               Begin DoDot:1

 +5                IF Y=48

                       FOR I=1:1:DGANUM

                           SET DGER=$SELECT(((DGSU1=DGSUFNAM(DGANUM))!(DGSU1=""))&((DGSU0=DGSUFNAM(DGANUM))!(DGSU0="")):0,1:1)

 +6                IF Y=49!(Y=50)

                       FOR I=1:1:DGANUM

                           SET DGER=$SELECT((Y=49&(DGSU1=DGSUFNAM(DGANUM))&("^9AA^9AB^9AC^9AD^9AE^"[(U_DGSU0_U))):0,(Y=50&(DGSU1=DGSUFNAM(DGANUM))&("^BU^BV^BW^BX^"[(U_DGSU0_U))):0,1:1)

               End DoDot:1

 +7        KILL DGANUM,DGSTATYP,DGSUFNAM,I

 +8        QUIT

DGPTFJ.m