DGPTF.m

DGPTF ;ALB/JDS/AS - PTF LOAD/EDIT DRIVER ; 5/17/05 12:13pm

 ;;5.3;PIMS;**26,58,164,195,397,1015,1016**;JUN 30, 2012;Build 20

 ;

 D LO^DGUTL

 I $D(^DISV(DUZ,"^DPT(")),$D(^("^DGPT(")) S A=+^("^DGPT("),B=+^("^DPT(") I $D(^DGPT(A,0)),$D(^DPT(B,0)) S:(+^DGPT(A,0)'=B&$D(^DGPT("B",B))) ^DISV(DUZ,"^DGPT(")=""

ASK W !! K DIC S DIC="^DGPT(",DIC(0)="EQMZA",DGPR=0,DIC("S")="I '$P(^DGPT(+Y,0),U,6)!($P(^(0),U,6)=1),$P(^(0),U,11)=1"

 D ^DIC G Q1:Y'>0 S PTF=+Y,DGREL=$S($D(^XUSEC("DG PTFREL",DUZ)):1,1:0)

 I '$D(^DGPT(PTF,"M",0))#2 S ^(0)="^45.02^^"

 K DIC S DFN=+Y(0),DGADM=+$P(Y(0),U,2),^DISV(DUZ,"^DPT(")=DFN,DGST=+$P(Y(0),U,6)

 N DGPMCA,DGPMAN D PM^DGPTUTL

 D:DGST=0 MT^DGPTUTL,INCOME^DGPTUTL1

 I DGST I 'DGREL!($D(DGQWK))!(DGST>1) W:$X>60 "   ???--Already ",$S(DGST=1:"Closed",DGST=2:"Released",1:"Transmitted") G ASK

 ;

EN1 ;

 K DGPTFE S DGPTFE=$P(^DGPT(PTF,0),"^",4)

 I 'DGPTFE,'DGST G UP:$P(DGPMAN,"^",16)'=PTF D:'$P(^DGPT(PTF,0),"^",5) SUF D LE^DGPTTS,DC

 I $D(DGQWK) D ^DGPTFQWK,Q1 S DGQWK=1 G DGPTF

 ;

GETD ;

 K A

 I $P(^DGPT(PTF,0),U,11)=1 D CEN^DGPTC1

 F I=0,.521,.11,.52,.321,.32,57,.3 S A(I)="" S:$D(^DPT(DFN,I))&('DGST) A(I)=^(I) I DGST S:$D(^DGP(45.84,PTF,$S('I:10,1:I))) A(I)=^($S('I:10,1:I))

 ;changed 6/17/98 for MST enhancement

 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

 K B F I=0,101,70 S B(I)="" S:$D(^DGPT(PTF,I)) B(I)=^(I)

 S A("CV")=$$CVEDT^DGCV(DFN,$P($G(B(0)),U,2))

 S A("SHAD")=$$GETSHAD^DGUTL3(DFN)

 S DGDD=+B(70),DGFC=+$P(B(0),U,3)

 S Y=DGDD D FMT^DGPTUTL

 S Y=DGADM D D^DGPTUTL S DGAD=Y,HEAD="Name: "_$P(A(0),U,1)_"  SSN: "_$P(A(0),U,9)_" Dt of Adm: "_DGAD

 S DGN=$S(DGST!DGPR:1,1:0)

 I DGPR S (DGST,DGPTFE)=1 G FAC^DGPTF1

 I DGPTFE,'DGST K DR S DIE="^DGPT(",DA=PTF,DR="2" D ^DIE K DR G Q:$D(Y) S DGADM=$P(^DGPT(PTF,0),U,2),^DISV(DUZ,"PTFAD",DFN)=DGADM,Y=DGADM D D^DGPTUTL S HEAD=$P(HEAD,DGAD,1)_Y

 G ^DGPTF1

 ;

Q I '$P(^DGPT(PTF,0),"^",4),'$P(^(0),U,6) W !,"  Updating TRANSFER DRGs" S DGADM=$P(^DGPT(PTF,0),U,2) D SUDO1^DGPTSUDO

 D Q1

 I $D(DGADPR)!($D(DGPTOUT)) K DGPTOUT Q

 G DGPTF

 ;

Q1 ; -- housekeeping

 I $D(IOM) S X=IOM X ^%ZOSF("RM")

 D KVAR^DGPTUTL1,KVAR^DGPTC1 K SDCLY

 Q

 ;

SUF I $D(^DIC(42,+$P(DGPMAN,U,6),0)) D

 .S DGX=$P(^(0),U,3),DGX=$S(DGX="":"",DGX="D":"D NUMACT^DGPTSUF(30)",DGX="NH":"D NUMACT^DGPTSUF(40)",1:"")

 .Q:DGX=""

 .X DGX Q:DGANUM'=1

 .N DGFDA,DGMSG

 .S DGFDA(45,PTF_",",5)=DGSUFNAM(DGANUM)

 .D FILE^DIE("","DGFDA","DGMSG")

 K DGANUM,DGSUFNAM,DGX

 Q

ORDER ; -- order mvt ; I1 := #mvts+1 ; M() := mvt array

 N DGRT S DGRT=$S(I1<25:"MT",1:"^UTILITY(""DGPTMT"",$J)") K @DGRT

 F I=0:0 S I=$O(M(I)) Q:'I  S NU=+$P(M(I),U,10),NU=$S('NU:9999999+I,1:NU),NU=$S($D(@DGRT@(NU)):NU+(I*.1),1:NU) S @DGRT@(NU,I)=M(I)

 S K=0 F I=0:0 S I=$O(@DGRT@(I)) Q:'I  S K=K+1,J=$O(@DGRT@(I,0)) S M(K)=@DGRT@(I,J)

 K @DGRT Q

 ;

ADM S DFN=+^DGPT(DA,0),%=$O(^("M","AM",0)) I %<X&(%>0) K X W !,"Not after first movement"

 Q:'$D(X)  I $D(^DGPT("AAD",DFN,X))&($P(^DGPT(DA,0),U,2)'=X) K X W !,"There is already a PTF entry at that time"

 Q

 ;

WR Q:'$D(^(0))  S DGNODE=^(0),DGADM=$P(DGNODE,U,2) W "  Admitted: ",$TR($$FMTE^XLFDT(DGADM,"5DF")," ","0")," "

 ; uses new FMTE parameter for XLFDT, Y2K in line WR

 ;

 F DGZ=6,4 S %=";"_$S($D(^DD(45,DGZ,0)):$P(^(0),U,3),1:"") W $P($P(%,";"_$P(DGNODE,U,DGZ)_":",2),";",1)_" "

 K DGNODE,DGZ Q

 ;

DC S DGPDN=$S($D(^DGPM(+$P(DGPMAN,"^",17),0)):^(0),1:"")

 S DGDC=+DGPDN,DG72=$S($D(^DG(405.2,+$P(DGPDN,"^",18),0)):$P(^(0),"^",8),1:0),DGTY=$S(DGDC:1,1:"")

 I DGDC F I=0:0 S I=$O(^DGPM("APMV",DFN,DGPMCA,I)) Q:I'>0  I $D(^DGPM(+$O(^(I,0)),0)),$P(^(0),"^",2)=2 S J=U_$P(^(0),"^",18)_U,DGTY=$S("^43^44^13^45^"[J:4,"^1^"[J:2,"^2^3^"[J:3,1:1) Q

 S X=$S($D(^DGPT(PTF,70)):^(70),1:"")

 S DR="70///"_$S(DGDC:"/"_DGDC,'X:"",1:"@")_$S(DG72:";72////"_DG72,1:"")_";72.1///"_$S(DGTY:"/"_DGTY,'$P(X,"^",14):"",1:"@"),DIE="^DGPT(",DA=PTF D ^DIE

 I DGDC>DT,$P(DGPDN,"^",18)=42 W:'$D(ZTQUEUED) !,"Discharge 'While ASIH' is in the future."

 K DG72,DGTY,DGPDN Q

 ;

UP S DIE="^DGPT(",DR="4///F",DA=PTF D ^DIE W !,"Pointer from Patient file is incorrect. Record changed to Fee Basis",! S DGPTFE=1 G GETD

DGPTF     ;ALB/JDS/AS - PTF LOAD/EDIT DRIVER ; 5/17/05 12:13pm

 +1       ;;5.3;PIMS;**26,58,164,195,397,1015,1016**;JUN 30, 2012;Build 20

 +2       ;

 +3        DO LO^DGUTL

 +4        IF $DATA(^DISV(DUZ,"^DPT("))

               IF $DATA(^("^DGPT("))

                   SET A=+^("^DGPT(")

                   SET B=+^("^DPT(")

                   IF $DATA(^DGPT(A,0))

                       IF $DATA(^DPT(B,0))

                           IF (+^DGPT(A,0)'=B&$DATA(^DGPT("B",B)))

                               SET ^DISV(DUZ,"^DGPT(")=""

ASK        WRITE !!

           KILL DIC

           SET DIC="^DGPT("

           SET DIC(0)="EQMZA"

           SET DGPR=0

           SET DIC("S")="I '$P(^DGPT(+Y,0),U,6)!($P(^(0),U,6)=1),$P(^(0),U,11)=1"

 +1        DO ^DIC

           IF Y'>0

               GOTO Q1

           SET PTF=+Y

           SET DGREL=$SELECT($DATA(^XUSEC("DG PTFREL",DUZ)):1,1:0)

 +2        IF '$DATA(^DGPT(PTF,"M",0))#2

               SET ^(0)="^45.02^^"

 +3        KILL DIC

           SET DFN=+Y(0)

           SET DGADM=+$PIECE(Y(0),U,2)

           SET ^DISV(DUZ,"^DPT(")=DFN

           SET DGST=+$PIECE(Y(0),U,6)

 +4        NEW DGPMCA,DGPMAN

           DO PM^DGPTUTL

 +5        IF DGST=0

               DO MT^DGPTUTL

               DO INCOME^DGPTUTL1

 +6        IF DGST

               IF 'DGREL!($DATA(DGQWK))!(DGST>1)

                   IF $X>60

                       WRITE "   ???--Already ",$SELECT(DGST=1:"Closed",DGST=2:"Released",1:"Transmitted")

                   GOTO ASK

 +7       ;

EN1       ;

 +1        KILL DGPTFE

           SET DGPTFE=$PIECE(^DGPT(PTF,0),"^",4)

 +2        IF 'DGPTFE

               IF 'DGST

                   IF $PIECE(DGPMAN,"^",16)'=PTF

                       GOTO UP

                   IF '$PIECE(^DGPT(PTF,0),"^",5)

                       DO SUF

                   DO LE^DGPTTS

                   DO DC

 +3        IF $DATA(DGQWK)

               DO ^DGPTFQWK

               DO Q1

               SET DGQWK=1

               GOTO DGPTF

 +4       ;

GETD      ;

 +1        KILL A

 +2        IF $PIECE(^DGPT(PTF,0),U,11)=1

               DO CEN^DGPTC1

 +3        FOR I=0,.521,.11,.52,.321,.32,57,.3

               SET A(I)=""

               IF $DATA(^DPT(DFN,I))&('DGST)

                   SET A(I)=^(I)

               IF DGST

                   IF $DATA(^DGP(45.84,PTF,$SELECT('I

                       SET A(I)=^($SELECT('I:10,1:I))

 +4       ;changed 6/17/98 for MST enhancement

 +5        SET A("MST")=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2,5)

 +6        KILL DGNTARR

 +7        SET A("NTR")=$SELECT($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")

 +8        KILL DGNTARR

 +9        KILL B

           FOR I=0,101,70

               SET B(I)=""

               IF $DATA(^DGPT(PTF,I))

                   SET B(I)=^(I)

 +10       SET A("CV")=$$CVEDT^DGCV(DFN,$PIECE($GET(B(0)),U,2))

 +11       SET A("SHAD")=$$GETSHAD^DGUTL3(DFN)

 +12       SET DGDD=+B(70)

           SET DGFC=+$PIECE(B(0),U,3)

 +13       SET Y=DGDD

           DO FMT^DGPTUTL

 +14       SET Y=DGADM

           DO D^DGPTUTL

           SET DGAD=Y

           SET HEAD="Name: "_$PIECE(A(0),U,1)_"  SSN: "_$PIECE(A(0),U,9)_" Dt of Adm: "_DGAD

 +15       SET DGN=$SELECT(DGST!DGPR:1,1:0)

 +16       IF DGPR

               SET (DGST,DGPTFE)=1

               GOTO FAC^DGPTF1

 +17       IF DGPTFE

               IF 'DGST

                   KILL DR

                   SET DIE="^DGPT("

                   SET DA=PTF

                   SET DR="2"

                   DO ^DIE

                   KILL DR

                   IF $DATA(Y)

                       GOTO Q

                   SET DGADM=$PIECE(^DGPT(PTF,0),U,2)

                   SET ^DISV(DUZ,"PTFAD",DFN)=DGADM

                   SET Y=DGADM

                   DO D^DGPTUTL

                   SET HEAD=$PIECE(HEAD,DGAD,1)_Y

 +18       GOTO ^DGPTF1

 +19      ;

Q          IF '$PIECE(^DGPT(PTF,0),"^",4)

               IF '$PIECE(^(0),U,6)

                   WRITE !,"  Updating TRANSFER DRGs"

                   SET DGADM=$PIECE(^DGPT(PTF,0),U,2)

                   DO SUDO1^DGPTSUDO

 +1        DO Q1

 +2        IF $DATA(DGADPR)!($DATA(DGPTOUT))

               KILL DGPTOUT

               QUIT 

 +3        GOTO DGPTF

 +4       ;

Q1        ; -- housekeeping

 +1        IF $DATA(IOM)

               SET X=IOM

               XECUTE ^%ZOSF("RM")

 +2        DO KVAR^DGPTUTL1

           DO KVAR^DGPTC1

           KILL SDCLY

 +3        QUIT 

 +4       ;

SUF        IF $DATA(^DIC(42,+$PIECE(DGPMAN,U,6),0))

               Begin DoDot:1

 +1                SET DGX=$PIECE(^(0),U,3)

                   SET DGX=$SELECT(DGX="":"",DGX="D":"D NUMACT^DGPTSUF(30)",DGX="NH":"D NUMACT^DGPTSUF(40)",1:"")

 +2                IF DGX=""

                       QUIT 

 +3                XECUTE DGX

                   IF DGANUM'=1

                       QUIT 

 +4                NEW DGFDA,DGMSG

 +5                SET DGFDA(45,PTF_",",5)=DGSUFNAM(DGANUM)

 +6                DO FILE^DIE("","DGFDA","DGMSG")

               End DoDot:1

 +7        KILL DGANUM,DGSUFNAM,DGX

 +8        QUIT 

ORDER     ; -- order mvt ; I1 := #mvts+1 ; M() := mvt array

 +1        NEW DGRT

           SET DGRT=$SELECT(I1<25:"MT",1:"^UTILITY(""DGPTMT"",$J)")

           KILL @DGRT

 +2        FOR I=0:0

               SET I=$ORDER(M(I))

               IF 'I

                   QUIT 

               SET NU=+$PIECE(M(I),U,10)

               SET NU=$SELECT('NU:9999999+I,1:NU)

               SET NU=$SELECT($DATA(@DGRT@(NU)):NU+(I*.1),1:NU)

               SET @DGRT@(NU,I)=M(I)

 +3        SET K=0

           FOR I=0:0

               SET I=$ORDER(@DGRT@(I))

               IF 'I

                   QUIT 

               SET K=K+1

               SET J=$ORDER(@DGRT@(I,0))

               SET M(K)=@DGRT@(I,J)

 +4        KILL @DGRT

           QUIT 

 +5       ;

ADM        SET DFN=+^DGPT(DA,0)

           SET %=$ORDER(^("M","AM",0))

           IF %<X&(%>0)

               KILL X

               WRITE !,"Not after first movement"

 +1        IF '$DATA(X)

               QUIT 

           IF $DATA(^DGPT("AAD",DFN,X))&($PIECE(^DGPT(DA,0),U,2)'=X)

               KILL X

               WRITE !,"There is already a PTF entry at that time"

 +2        QUIT 

 +3       ;

WR         IF '$DATA(^(0))

               QUIT 

           SET DGNODE=^(0)

           SET DGADM=$PIECE(DGNODE,U,2)

           WRITE "  Admitted: ",$TRANSLATE($$FMTE^XLFDT(DGADM,"5DF")," ","0")," "

 +1       ; uses new FMTE parameter for XLFDT, Y2K in line WR

 +2       ;

 +3        FOR DGZ=6,4

               SET %=";"_$SELECT($DATA(^DD(45,DGZ,0)):$PIECE(^(0),U,3),1:"")

               WRITE $PIECE($PIECE(%,";"_$PIECE(DGNODE,U,DGZ)_":",2),";",1)_" "

 +4        KILL DGNODE,DGZ

           QUIT 

 +5       ;

DC         SET DGPDN=$SELECT($DATA(^DGPM(+$PIECE(DGPMAN,"^",17),0)):^(0),1:"")

 +1        SET DGDC=+DGPDN

           SET DG72=$SELECT($DATA(^DG(405.2,+$PIECE(DGPDN,"^",18),0)):$PIECE(^(0),"^",8),1:0)

           SET DGTY=$SELECT(DGDC:1,1:"")

 +2        IF DGDC

               FOR I=0:0

                   SET I=$ORDER(^DGPM("APMV",DFN,DGPMCA,I))

                   IF I'>0

                       QUIT 

                   IF $DATA(^DGPM(+$ORDER(^(I,0)),0))

                       IF $PIECE(^(0),"^",2)=2

                           SET J=U_$PIECE(^(0),"^",18)_U

                           SET DGTY=$SELECT("^43^44^13^45^"[J:4,"^1^"[J:2,"^2^3^"[J:3,1:1)

                           QUIT 

 +3        SET X=$SELECT($DATA(^DGPT(PTF,70)):^(70),1:"")

 +4        SET DR="70///"_$SELECT(DGDC:"/"_DGDC,'X:"",1:"@")_$SELECT(DG72:";72////"_DG72,1:"")_";72.1///"_$SELECT(DGTY:"/"_DGTY,'$PIECE(X,"^",14):"",1:"@")

           SET DIE="^DGPT("

           SET DA=PTF

           DO ^DIE

 +5        IF DGDC>DT

               IF $PIECE(DGPDN,"^",18)=42

                   IF '$DATA(ZTQUEUED)

                       WRITE !,"Discharge 'While ASIH' is in the future."

 +6        KILL DG72,DGTY,DGPDN

           QUIT 

 +7       ;

UP         SET DIE="^DGPT("

           SET DR="4///F"

           SET DA=PTF

           DO ^DIE

           WRITE !,"Pointer from Patient file is incorrect. Record changed to Fee Basis",!

           SET DGPTFE=1

           GOTO GETD