- DGPTFUP ;ALB/ABS,BOK - Updates Means Test, LOS, TRANSFER DRGs in PTF records ; 3/28/02 11:54am
- ;;5.3;Registration;**441,478,1015**;Aug 13, 1993;Build 21
- ACTIVE ;this call should be queued to run nightly to update the LOS in active admission PTF records and the Means Test Indicator in Open PTF records
- D NOW^%DTC S DT=X,U="^",(DGBGJ,DGLN)=1
- F PTF=0:0 S PTF=$O(^DGPT("AS",0,PTF)) Q:PTF'>0 I $D(^DGPT(PTF,0)),$P(^(0),U,11)=1 S DFN=+^(0),DGADM=$P(^(0),U,2),DGPMCA=$O(^DGPM("APTT1",DFN,DGADM,0)),DGPMAN=$S($D(^DGPM(+DGPMCA,0)):^(0),1:"") I DGPMAN D:DGADM>2860700 MT^DGPTUTL D LOS
- K DGADM,DGADIFN,PTF,DFN,DGLEAVE,DGMV,DGMVDT,DGPASS,DGTOT,DGTYPE,X,X1,X2,DGCUM,DGMT,DGBGJ,DGLN,DGPMAN,DGPMCA Q
- LOS Q:'$D(^DGPT("AADA",DGADM,PTF))!('$D(^DGPT(PTF,"M",1,0))) I '$D(^DGPT(PTF,"M",1,"P")) S ^DGPT(PTF,"M",1,"P")=""
- S DGMVDT=1,DGCUM=0 F X=1:0 S X=$O(^DGPT(PTF,"M",X)) Q:X'>0 I $D(^(X,"P")),$P(^("P"),"^",3)>DGMVDT S DGMVDT=$P(^("P"),"^",3),DGCUM=$P(^("P"),"^",6)
- I DGMVDT'>1 S DGMVDT=DGADM
- S (DGLEAVE,DGPASS)=0,X1=DT,X2=DGMVDT D ^%DTC S DGTOT=$S(X>0:X,1:1)
- F DGMV=(DGMVDT-.1):0 S DGMV=$O(^DGPM("APTT2",DFN,DGMV)) Q:DGMV'>0 S X=$O(^DGPM("APTT2",DFN,DGMV,0)) I $S('$D(^DGPM(+X,0)):0,$P(^(0),"^",14)=DGPMCA:1,1:0) S DGTYPE=+$P(^(0),"^",18) I DGTYPE=1!(DGTYPE=2)!(DGTYPE=3) D ABSENT
- S DGTOT=DGTOT-DGPASS-DGLEAVE
- N DGFDA,DGMSG
- S DGFDA(45.02,1_","_PTF_",",23)=DGTOT
- S DGFDA(45.02,1_","_PTF_",",25)=DGTOT+DGCUM
- D FILE^DIE("","DGFDA","DGMSG")
- Q
- ABSENT S X2=DGMV,X=$O(^DGPM("APTT2",DFN,DGMV)),X1=$S(X>0:X,1:DT) D ^%DTC I DGTYPE=1 S DGPASS=DGPASS+X Q
- S DGLEAVE=DGLEAVE+X Q
- ;
- ;ADDING TRANSFER DRGs
- ALL D DT^DICRW S U="^" W !?5,"===> PTF TRANSFER DRG update beginning..."
- F PTF=0:0 S PTF=$O(^DGPT(PTF)) Q:PTF'>0 D UPDATE
- G Q
- ;
- SOME ;
- W !!?2,"This option will recalculate the TRANSFER DRG's for all",!?2,"current fiscal year PTF records."
- W !!?2,"Do you want to continue" S %=2 D YN^DICN Q:%=-1!(%=2)
- I '% W !?2,"Answer 'YES' to begin recalculation or 'NO' to stop." G SOME
- W !?5,"===> PTF partial TRANSFER DRG update beginning with "
- W !?5," discharge dates for the current fiscal year..."
- ;
- D DT^DICRW S U="^",DGFYDT=$S($E(DT,4,5)<10:($E(DT,1,3)-1),1:$E(DT,1,3))_1000
- N DGD1SAV
- F DGXREF="ADS","AADA" S DGD1SAV=0 F DGD1=$S(DGXREF="ADS":DGFYDT,1:0):0 S DGD1=$O(^DGPT(DGXREF,DGD1)) Q:'DGD1 Q:DGD1<DGD1SAV F PTF=0:0 S PTF=$O(^DGPT(DGXREF,DGD1,PTF)) Q:'PTF D UPDATE
- Q W !!?5,"===> PTF TRANSFER DRG update complete"
- K PTF,DGD1,DGFYDT,DGXREF Q
- ;
- UPDATE ; -- update xfr drg's for PTF ifn
- S DGD1SAV=DGD1
- G UPDATEQ:'$D(^DGPT(PTF,0)) S DGNODE=^(0)
- G UPDATEQ:$S($P(DGNODE,"^",11)>1:1,1:$P(DGNODE,"^",4))
- D PM^DGPTUTL G UPDATEQ:'DGPMCA
- K DGTDD,DGPRD,DGNXD F I=0:0 S I=$O(^DGPT(PTF,"M",I)) Q:I'>0 D
- .N FLD,DGFDA,DGMSG
- .F FLD=20:1:25 S DGFDA(45.02,I_","_PTF_",",FLD)="@"
- .D FILE^DIE("","DGFDA","DGMSG")
- S DFN=+DGNODE,DGADM=+$P(DGNODE,U,2)
- D SUDO1^DGPTSUDO
- W:'(PTF#300) !," TRANSFER DRG update in progress...on IFN ",PTF
- UPDATEQ K DGPMCA,DGPMAN,DGNODE,DGADM,DFN Q
- ;
- ZERO ;LOOK FOR MISSING 0 NODE IN 501 MULTIPLE
- D LO^DGUTL F I=0:0 S I=$O(^DGPT(I)) Q:I'>0 S:'$D(^DGPT(I,0)) ^DGPT(I,0)="" I $D(^DGPT(I,"M")),'$D(^("M",0)) S ^(0)="^45.02AI"
- K I Q
- DGPTFUP ;ALB/ABS,BOK - Updates Means Test, LOS, TRANSFER DRGs in PTF records ; 3/28/02 11:54am
- +1 ;;5.3;Registration;**441,478,1015**;Aug 13, 1993;Build 21
- ACTIVE ;this call should be queued to run nightly to update the LOS in active admission PTF records and the Means Test Indicator in Open PTF records
- +1 DO NOW^%DTC
- SET DT=X
- SET U="^"
- SET (DGBGJ,DGLN)=1
- +2 FOR PTF=0:0
- SET PTF=$ORDER(^DGPT("AS",0,PTF))
- IF PTF'>0
- QUIT
- IF $DATA(^DGPT(PTF,0))
- IF $PIECE(^(0),U,11)=1
- SET DFN=+^(0)
- SET DGADM=$PIECE(^(0),U,2)
- SET DGPMCA=$ORDER(^DGPM("APTT1",DFN,DGADM,0))
- SET DGPMAN=$SELECT($DATA(^DGPM(+DGPMCA,0)):^(0),1:"")
- IF DGPMAN
- IF DGADM>2860700
- DO MT^DGPTUTL
- DO LOS
- +3 KILL DGADM,DGADIFN,PTF,DFN,DGLEAVE,DGMV,DGMVDT,DGPASS,DGTOT,DGTYPE,X,X1,X2,DGCUM,DGMT,DGBGJ,DGLN,DGPMAN,DGPMCA
- QUIT
- LOS IF '$DATA(^DGPT("AADA",DGADM,PTF))!('$DATA(^DGPT(PTF,"M",1,0)))
- QUIT
- IF '$DATA(^DGPT(PTF,"M",1,"P"))
- SET ^DGPT(PTF,"M",1,"P")=""
- +1 SET DGMVDT=1
- SET DGCUM=0
- FOR X=1:0
- SET X=$ORDER(^DGPT(PTF,"M",X))
- IF X'>0
- QUIT
- IF $DATA(^(X,"P"))
- IF $PIECE(^("P"),"^",3)>DGMVDT
- SET DGMVDT=$PIECE(^("P"),"^",3)
- SET DGCUM=$PIECE(^("P"),"^",6)
- +2 IF DGMVDT'>1
- SET DGMVDT=DGADM
- +3 SET (DGLEAVE,DGPASS)=0
- SET X1=DT
- SET X2=DGMVDT
- DO ^%DTC
- SET DGTOT=$SELECT(X>0:X,1:1)
- +4 FOR DGMV=(DGMVDT-.1):0
- SET DGMV=$ORDER(^DGPM("APTT2",DFN,DGMV))
- IF DGMV'>0
- QUIT
- SET X=$ORDER(^DGPM("APTT2",DFN,DGMV,0))
- IF $SELECT('$DATA(^DGPM(+X,0)):0,$PIECE(^(0),"^",14)=DGPMCA:1,1:0)
- SET DGTYPE=+$PIECE(^(0),"^",18)
- IF DGTYPE=1!(DGTYPE=2)!(DGTYPE=3)
- DO ABSENT
- +5 SET DGTOT=DGTOT-DGPASS-DGLEAVE
- +6 NEW DGFDA,DGMSG
- +7 SET DGFDA(45.02,1_","_PTF_",",23)=DGTOT
- +8 SET DGFDA(45.02,1_","_PTF_",",25)=DGTOT+DGCUM
- +9 DO FILE^DIE("","DGFDA","DGMSG")
- +10 QUIT
- ABSENT SET X2=DGMV
- SET X=$ORDER(^DGPM("APTT2",DFN,DGMV))
- SET X1=$SELECT(X>0:X,1:DT)
- DO ^%DTC
- IF DGTYPE=1
- SET DGPASS=DGPASS+X
- QUIT
- +1 SET DGLEAVE=DGLEAVE+X
- QUIT
- +2 ;
- +3 ;ADDING TRANSFER DRGs
- ALL DO DT^DICRW
- SET U="^"
- WRITE !?5,"===> PTF TRANSFER DRG update beginning..."
- +1 FOR PTF=0:0
- SET PTF=$ORDER(^DGPT(PTF))
- IF PTF'>0
- QUIT
- DO UPDATE
- +2 GOTO Q
- +3 ;
- SOME ;
- +1 WRITE !!?2,"This option will recalculate the TRANSFER DRG's for all",!?2,"current fiscal year PTF records."
- +2 WRITE !!?2,"Do you want to continue"
- SET %=2
- DO YN^DICN
- IF %=-1!(%=2)
- QUIT
- +3 IF '%
- WRITE !?2,"Answer 'YES' to begin recalculation or 'NO' to stop."
- GOTO SOME
- +4 WRITE !?5,"===> PTF partial TRANSFER DRG update beginning with "
- +5 WRITE !?5," discharge dates for the current fiscal year..."
- +6 ;
- +7 DO DT^DICRW
- SET U="^"
- SET DGFYDT=$SELECT($EXTRACT(DT,4,5)<10:($EXTRACT(DT,1,3)-1),1:$EXTRACT(DT,1,3))_1000
- +8 NEW DGD1SAV
- +9 FOR DGXREF="ADS","AADA"
- SET DGD1SAV=0
- FOR DGD1=$SELECT(DGXREF="ADS":DGFYDT,1:0):0
- SET DGD1=$ORDER(^DGPT(DGXREF,DGD1))
- IF 'DGD1
- QUIT
- IF DGD1<DGD1SAV
- QUIT
- FOR PTF=0:0
- SET PTF=$ORDER(^DGPT(DGXREF,DGD1,PTF))
- IF 'PTF
- QUIT
- DO UPDATE
- Q WRITE !!?5,"===> PTF TRANSFER DRG update complete"
- +1 KILL PTF,DGD1,DGFYDT,DGXREF
- QUIT
- +2 ;
- UPDATE ; -- update xfr drg's for PTF ifn
- +1 SET DGD1SAV=DGD1
- +2 IF '$DATA(^DGPT(PTF,0))
- GOTO UPDATEQ
- SET DGNODE=^(0)
- +3 IF $SELECT($PIECE(DGNODE,"^",11)>1:1,1:$PIECE(DGNODE,"^",4))
- GOTO UPDATEQ
- +4 DO PM^DGPTUTL
- IF 'DGPMCA
- GOTO UPDATEQ
- +5 KILL DGTDD,DGPRD,DGNXD
- FOR I=0:0
- SET I=$ORDER(^DGPT(PTF,"M",I))
- IF I'>0
- QUIT
- Begin DoDot:1
- +6 NEW FLD,DGFDA,DGMSG
- +7 FOR FLD=20:1:25
- SET DGFDA(45.02,I_","_PTF_",",FLD)="@"
- +8 DO FILE^DIE("","DGFDA","DGMSG")
- End DoDot:1
- +9 SET DFN=+DGNODE
- SET DGADM=+$PIECE(DGNODE,U,2)
- +10 DO SUDO1^DGPTSUDO
- +11 IF '(PTF#300)
- WRITE !," TRANSFER DRG update in progress...on IFN ",PTF
- UPDATEQ KILL DGPMCA,DGPMAN,DGNODE,DGADM,DFN
- QUIT
- +1 ;
- ZERO ;LOOK FOR MISSING 0 NODE IN 501 MULTIPLE
- +1 DO LO^DGUTL
- FOR I=0:0
- SET I=$ORDER(^DGPT(I))
- IF I'>0
- QUIT
- IF '$DATA(^DGPT(I,0))
- SET ^DGPT(I,0)=""
- IF $DATA(^DGPT(I,"M"))
- IF '$DATA(^("M",0))
- SET ^(0)="^45.02AI"
- +2 KILL I
- QUIT
