- DGAINP0 ;ALB/RMO - Calculate 45 Patient Days of Care for Psych on AMIS 334 ; 14 MAY 90 11:10 am
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- ;=======================================================================
- ;The Psych 1-45 patient days of care are calculated by looping
- ;through the admission and transfer movements.
- ;
- ;Input:
- ; DGBOM -First day of Month/Year in internal date format
- ; DGEOM -Last day of Month/Year in internal date format
- ;
- ;Output:
- ; DGL45 -Array contains 1-45 day psych stats by division
- ;=======================================================================
- START ;Starting 45 days Prior to the BOM check Admissions and Transfers
- S DGMVTP="^2^3^25^26^" F I=0:0 S I=$O(^DG(40.8,I)) Q:'I S DGL45(I)=0
- S X1=DGBOM,X2=-45 D C^%DTC S DGSTDT=X,X1=DGEOM,X2=1 D C^%DTC S DGENDT=X
- F DGPMTT="ATT1","ATT2" F DGPMTDT=DGSTDT:0 S DGPMTDT=$O(^DGPM(DGPMTT,DGPMTDT)) Q:'DGPMTDT!(DGPMTDT>DGENDT) S DGPMVDT=DGPMTDT\1 D MVT
- ;
- Q K DFN,DGABD,DGABF,DGADM,DGBDT,DGDIV,DGDMDT,DGDV,DGEDT,DGENDT,DGLOD,DGLSD,DGLSDT,DGMVTP,DGNPF,DGPM0,DGPMCA,DGPMCA0,DGPMDT,DGPMI,DGPMTDT,DGPMTT,DGPMVDT,DGREC,DGSEG,DGSTDT,DGTMDT,DGW0,I,X,X1,X2
- Q
- ;
- MVT ;Check Patient Movements associated with Psych Service
- F DGPMI=0:0 S DGPMI=$O(^DGPM(DGPMTT,DGPMTDT,DGPMI)) Q:'DGPMI I $D(^DGPM(DGPMI,0)) S DGPM0=^(0) D SER I DGSEG S DGDIV=DGDV D CHK
- Q
- ;
- CHK ;Check Corresponding Admission Movements
- Q:$P(DGPM0,"^",18)=13!($P(DGPM0,"^",18)=44) ;NHCU/DOM Transfer
- S DFN=+$P(DGPM0,"^",3),DGPMCA=+$P(DGPM0,"^",14),DGPMCA0=$S($D(^DGPM(DGPMCA,0)):^(0),1:0) Q:'DGPMCA0
- S DGPMDT=$O(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-DGPMTDT))) I DGPMDT,$D(^DGPM(+$O(^(DGPMDT,0)),0)) S DGPM0=^(0) D SER Q:DGSEG
- S DGADM=$P(DGPMCA0,"^"),DGDMDT=$S($D(^DGPM(+$P(DGPMCA0,"^",17),0)):$P(^(0),"^"),1:0)\1
- S X1=DGPMVDT,X2=44 D C^%DTC S DGLSDT=X,DGBDT=DGPMVDT,DGTMDT=0,(DGNPF,DGABF)=0
- F DGPMDT=DGPMTDT:0 S DGPMDT=$O(^DGPM("APCA",DFN,DGPMCA,DGPMDT)) Q:'DGPMDT!(DGNPF)!(DGPMDT\1>DGLSDT)!(DGPMDT\1>DGEOM) I $D(^DGPM(+$O(^(DGPMDT,0)),0)),$P(^(0),"^",2)=2 S DGPM0=^(0),DGTMDT=DGPMDT\1 D TRF
- D CAL
- Q
- ;
- TRF ;Check Transfer Movement
- D SER S DGNPF=$S('DGSEG:1,1:0),DGABF=$S(DGMVTP[("^"_$P(DGPM0,"^",18)_"^"):1,1:0)
- Q
- ;
- SER ;Check if Ward associate with the Movement is Psych Service
- S DGW0=$S($D(^DIC(42,+$P(DGPM0,"^",6),0)):^(0),1:""),DGDV=$S($D(^DG(40.8,+$P(DGW0,"^",11),0)):+$P(DGW0,"^",11),1:0),DGSEG=$S(DGDV&($P(DGW0,"^",3)="P"):334,1:0)
- Q
- ;
- CAL ;Calculate Patient Days of Care Less than Forty-five
- S DGEDT=$S(DGTMDT&(DGNPF):DGTMDT,DGDMDT&(DGDMDT'>DGEOM)&(DGDMDT'>DGLSDT):DGDMDT,DGEOM>DGLSDT:DGLSDT,1:DGEOM)
- Q:DGEDT<DGBOM
- S DGBDT=$S(DGBDT<DGBOM:DGBOM,1:DGBDT)
- S X2=DGBDT,X1=DGEDT D ^%DTC S DGLOD=X
- D CALC^DGUTL2 S DGABD=DGREC
- S DGLSD=$S((DGADM\1)=DGDMDT:1,(DGTMDT&(DGNPF))!(DGDMDT&(DGDMDT'>DGEOM)&(DGDMDT'>DGLSDT))!(DGABF):0,1:1)
- S DGL45=DGLOD-DGABD+DGLSD
- S DGL45(DGDIV)=DGL45(DGDIV)+DGL45
- Q
- DGAINP0 ;ALB/RMO - Calculate 45 Patient Days of Care for Psych on AMIS 334 ; 14 MAY 90 11:10 am
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- +2 ;=======================================================================
- +3 ;The Psych 1-45 patient days of care are calculated by looping
- +4 ;through the admission and transfer movements.
- +5 ;
- +6 ;Input:
- +7 ; DGBOM -First day of Month/Year in internal date format
- +8 ; DGEOM -Last day of Month/Year in internal date format
- +9 ;
- +10 ;Output:
- +11 ; DGL45 -Array contains 1-45 day psych stats by division
- +12 ;=======================================================================
- START ;Starting 45 days Prior to the BOM check Admissions and Transfers
- +1 SET DGMVTP="^2^3^25^26^"
- FOR I=0:0
- SET I=$ORDER(^DG(40.8,I))
- IF 'I
- QUIT
- SET DGL45(I)=0
- +2 SET X1=DGBOM
- SET X2=-45
- DO C^%DTC
- SET DGSTDT=X
- SET X1=DGEOM
- SET X2=1
- DO C^%DTC
- SET DGENDT=X
- +3 FOR DGPMTT="ATT1","ATT2"
- FOR DGPMTDT=DGSTDT:0
- SET DGPMTDT=$ORDER(^DGPM(DGPMTT,DGPMTDT))
- IF 'DGPMTDT!(DGPMTDT>DGENDT)
- QUIT
- SET DGPMVDT=DGPMTDT\1
- DO MVT
- +4 ;
- Q KILL DFN,DGABD,DGABF,DGADM,DGBDT,DGDIV,DGDMDT,DGDV,DGEDT,DGENDT,DGLOD,DGLSD,DGLSDT,DGMVTP,DGNPF,DGPM0,DGPMCA,DGPMCA0,DGPMDT,DGPMI,DGPMTDT,DGPMTT,DGPMVDT,DGREC,DGSEG,DGSTDT,DGTMDT,DGW0,I,X,X1,X2
- +1 QUIT
- +2 ;
- MVT ;Check Patient Movements associated with Psych Service
- +1 FOR DGPMI=0:0
- SET DGPMI=$ORDER(^DGPM(DGPMTT,DGPMTDT,DGPMI))
- IF 'DGPMI
- QUIT
- IF $DATA(^DGPM(DGPMI,0))
- SET DGPM0=^(0)
- DO SER
- IF DGSEG
- SET DGDIV=DGDV
- DO CHK
- +2 QUIT
- +3 ;
- CHK ;Check Corresponding Admission Movements
- +1 ;NHCU/DOM Transfer
- IF $PIECE(DGPM0,"^",18)=13!($PIECE(DGPM0,"^",18)=44)
- QUIT
- +2 SET DFN=+$PIECE(DGPM0,"^",3)
- SET DGPMCA=+$PIECE(DGPM0,"^",14)
- SET DGPMCA0=$SELECT($DATA(^DGPM(DGPMCA,0)):^(0),1:0)
- IF 'DGPMCA0
- QUIT
- +3 SET DGPMDT=$ORDER(^DGPM("APMV",DFN,DGPMCA,(9999999.9999999-DGPMTDT)))
- IF DGPMDT
- IF $DATA(^DGPM(+$ORDER(^(DGPMDT,0)),0))
- SET DGPM0=^(0)
- DO SER
- IF DGSEG
- QUIT
- +4 SET DGADM=$PIECE(DGPMCA0,"^")
- SET DGDMDT=$SELECT($DATA(^DGPM(+$PIECE(DGPMCA0,"^",17),0)):$PIECE(^(0),"^"),1:0)\1
- +5 SET X1=DGPMVDT
- SET X2=44
- DO C^%DTC
- SET DGLSDT=X
- SET DGBDT=DGPMVDT
- SET DGTMDT=0
- SET (DGNPF,DGABF)=0
- +6 FOR DGPMDT=DGPMTDT:0
- SET DGPMDT=$ORDER(^DGPM("APCA",DFN,DGPMCA,DGPMDT))
- IF 'DGPMDT!(DGNPF)!(DGPMDT\1>DGLSDT)!(DGPMDT\1>DGEOM)
- QUIT
- IF $DATA(^DGPM(+$ORDER(^(DGPMDT,0)),0))
- IF $PIECE(^(0),"^",2)=2
- SET DGPM0=^(0)
- SET DGTMDT=DGPMDT\1
- DO TRF
- +7 DO CAL
- +8 QUIT
- +9 ;
- TRF ;Check Transfer Movement
- +1 DO SER
- SET DGNPF=$SELECT('DGSEG:1,1:0)
- SET DGABF=$SELECT(DGMVTP[("^"_$PIECE(DGPM0,"^",18)_"^"):1,1:0)
- +2 QUIT
- +3 ;
- SER ;Check if Ward associate with the Movement is Psych Service
- +1 SET DGW0=$SELECT($DATA(^DIC(42,+$PIECE(DGPM0,"^",6),0)):^(0),1:"")
- SET DGDV=$SELECT($DATA(^DG(40.8,+$PIECE(DGW0,"^",11),0)):+$PIECE(DGW0,"^",11),1:0)
- SET DGSEG=$SELECT(DGDV&($PIECE(DGW0,"^",3)="P"):334,1:0)
- +2 QUIT
- +3 ;
- CAL ;Calculate Patient Days of Care Less than Forty-five
- +1 SET DGEDT=$SELECT(DGTMDT&(DGNPF):DGTMDT,DGDMDT&(DGDMDT'>DGEOM)&(DGDMDT'>DGLSDT):DGDMDT,DGEOM>DGLSDT:DGLSDT,1:DGEOM)
- +2 IF DGEDT<DGBOM
- QUIT
- +3 SET DGBDT=$SELECT(DGBDT<DGBOM:DGBOM,1:DGBDT)
- +4 SET X2=DGBDT
- SET X1=DGEDT
- DO ^%DTC
- SET DGLOD=X
- +5 DO CALC^DGUTL2
- SET DGABD=DGREC
- +6 SET DGLSD=$SELECT((DGADM\1)=DGDMDT:1,(DGTMDT&(DGNPF))!(DGDMDT&(DGDMDT'>DGEOM)&(DGDMDT'>DGLSDT))!(DGABF):0,1:1)
- +7 SET DGL45=DGLOD-DGABD+DGLSD
- +8 SET DGL45(DGDIV)=DGL45(DGDIV)+DGL45
- +9 QUIT
