DGAINP0 ;ALB/RMO - Calculate 45 Patient Days of Care for Psych on AMIS 334 ; 14 MAY 90 11:10 am
;;5.3;Registration;;Aug 13, 1993
;=======================================================================
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGAINP0 2926 printed Sep 23, 2025@20:17:10 Page 2
DGAINP0 ;ALB/RMO - Calculate 45 Patient Days of Care for Psych on AMIS 334 ; 14 MAY 90 11:10 am
+1 ;;5.3;Registration;;Aug 13, 1993
+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
