- DGPTF ;ALB/JDS,AS - PTF LOAD/EDIT DRIVER ;Aug 20, 2020@09:28
- ;;5.3;Registration;**26,58,164,195,397,565,664,850,932,1020,1057**;Aug 13, 1993;Build 17
- ;
- 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"
- ;DG*5.3*861 Added DGRELKEY variable to hold the value for DGREL that is killed in ^EASECU21
- N DGRELKEY D ^DIC G Q1:Y'>0 S PTF=+Y,(DGRELKEY,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))
- 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
- I DGPTFE,'DGST S DR="14//^S X=$$EXTERNAL^DILFD(45,2,,$G(DGADM))" D ^DIE K DR G Q:$D(Y) ; DG*5.3*1057
- S DGIDTS=$P(^DGPT(PTF,0),U,14) ; DG*5.3*1057
- 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)) S DGX=$P(^(0),U,3) D
- .S 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
- N DGRT82 S DGRT82=$S(I1<25:"MT82",1:"^UTILITY(""DGPTMT82"",$J)") K @DGRT82
- F I=0:0 S I=$O(M(I)) Q:'I D
- . S NU=+$P(M(I),U,10),NU=$S('NU:9999999+I,1:NU)
- . S NU=$S($D(@DGRT@(NU)):NU+(I*.1),1:NU) S @DGRT@(NU,I)=M(I),@DGRT82@(NU,I)=$G(M(I,82))
- S K=0 F I=0:0 S I=$O(@DGRT@(I)) Q:'I D
- . S K=K+1,J=$O(@DGRT@(I,0)) S M(K)=@DGRT@(I,J),M(K,82)=@DGRT82@(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 ;Called from ^DD(45,0,"ID","WR")
- Q:'$D(^DGPT(+$G(Y),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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTF 4668 printed Feb 19, 2025@00:18:01 Page 2
- DGPTF ;ALB/JDS,AS - PTF LOAD/EDIT DRIVER ;Aug 20, 2020@09:28
- +1 ;;5.3;Registration;**26,58,164,195,397,565,664,850,932,1020,1057**;Aug 13, 1993;Build 17
- +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(")=""
- +5 ;
- 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 ;DG*5.3*861 Added DGRELKEY variable to hold the value for DGREL that is killed in ^EASECU21
- +2 NEW DGRELKEY
- DO ^DIC
- if Y'>0
- GOTO Q1
- SET PTF=+Y
- SET (DGRELKEY,DGREL)=$SELECT($DATA(^XUSEC("DG PTFREL",DUZ)):1,1:0)
- +3 IF '$DATA(^DGPT(PTF,"M",0))#2
- SET ^(0)="^45.02^^"
- +4 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)
- +5 NEW DGPMCA,DGPMAN
- DO PM^DGPTUTL
- +6 if DGST=0
- DO MT^DGPTUTL
- DO INCOME^DGPTUTL1
- +7 IF DGST
- IF 'DGREL!($DATA(DGQWK))!(DGST>1)
- if $X>60
- WRITE " ???--Already ",$SELECT(DGST=1:"Closed",DGST=2:"Released",1:"Transmitted")
- GOTO ASK
- +8 ;
- 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 SET A("MST")=$PIECE($$GETSTAT^DGMSTAPI(DFN),U,2,5)
- +5 KILL DGNTARR
- +6 SET A("NTR")=$SELECT($$GETCUR^DGNTAPI(DFN,"DGNTARR")>0:DGNTARR("INTRP"),1:"")
- +7 KILL DGNTARR
- +8 KILL B
- FOR I=0,101,70
- SET B(I)=""
- if $DATA(^DGPT(PTF,I))
- SET B(I)=^(I)
- +9 SET A("CV")=$$CVEDT^DGCV(DFN,$PIECE($GET(B(0)),U,2))
- +10 SET A("SHAD")=$$GETSHAD^DGUTL3(DFN)
- +11 SET DGDD=+B(70)
- SET DGFC=+$PIECE(B(0),U,3)
- +12 SET Y=DGDD
- DO FMT^DGPTUTL
- +13 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
- +14 SET DGN=$SELECT(DGST!DGPR:1,1:0)
- +15 IF DGPR
- SET (DGST,DGPTFE)=1
- GOTO FAC^DGPTF1
- +16 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
- +17 ; DG*5.3*1057
- IF DGPTFE
- IF 'DGST
- SET DR="14//^S X=$$EXTERNAL^DILFD(45,2,,$G(DGADM))"
- DO ^DIE
- KILL DR
- if $DATA(Y)
- GOTO Q
- +18 ; DG*5.3*1057
- SET DGIDTS=$PIECE(^DGPT(PTF,0),U,14)
- +19 GOTO ^DGPTF1
- +20 ;
- 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))
- SET DGX=$PIECE(^(0),U,3)
- Begin DoDot:1
- +1 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 NEW DGRT82
- SET DGRT82=$SELECT(I1<25:"MT82",1:"^UTILITY(""DGPTMT82"",$J)")
- KILL @DGRT82
- +3 FOR I=0:0
- SET I=$ORDER(M(I))
- if 'I
- QUIT
- Begin DoDot:1
- +4 SET NU=+$PIECE(M(I),U,10)
- SET NU=$SELECT('NU:9999999+I,1:NU)
- +5 SET NU=$SELECT($DATA(@DGRT@(NU)):NU+(I*.1),1:NU)
- SET @DGRT@(NU,I)=M(I)
- SET @DGRT82@(NU,I)=$GET(M(I,82))
- End DoDot:1
- +6 SET K=0
- FOR I=0:0
- SET I=$ORDER(@DGRT@(I))
- if 'I
- QUIT
- Begin DoDot:1
- +7 SET K=K+1
- SET J=$ORDER(@DGRT@(I,0))
- SET M(K)=@DGRT@(I,J)
- SET M(K,82)=@DGRT82@(I,J)
- End DoDot:1
- +8 KILL @DGRT
- QUIT
- +9 ;
- 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 ;Called from ^DD(45,0,"ID","WR")
- +1 if '$DATA(^DGPT(+$GET(Y),0))
- QUIT
- SET DGNODE=^(0)
- SET DGADM=$PIECE(DGNODE,U,2)
- WRITE " Admitted: ",$TRANSLATE($$FMTE^XLFDT(DGADM,"5DF")," ","0")," "
- +2 ; uses new FMTE parameter for XLFDT, Y2K in line WR
- +3 ;
- +4 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)_" "
- +5 KILL DGNODE,DGZ
- QUIT
- +6 ;
- 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