BDGAD5 ; IHS/ANMC/LJF - A&D PTS REMAINING ;
;;5.3;PIMS;**1009,1012**;APR 26, 2002
;
;cmi/anch/maw 2/11/2008 added fix in SERV PATCH 1009
;
NEW PREV,CURR
S CURR=BDGT
S PREV=$$FMADD^XLFDT(CURR,-1) ;previous day
;
SERV ; loop through services and fill in patients remaining
NEW SRV,REMA,REMP,NEWA,NEWP,N
S SRV=0 F S SRV=$O(^BDGCTX(SRV)) Q:'SRV D
. Q:'$D(^BDGCTX(SRV,1,PREV,0)) ;cmi/maw 2/11/2008 quit if no current date for service PATCH 1009
. Q:'$D(^BDGCTX(SRV,1,CURR,0)) ;cmi/maw 4/23/2010 quit if no current date for service PATCH 1012
. ;
. ; if no activity, bring old numbers forward
. I $P(^BDGCTX(SRV,1,CURR,0),U,2,99)="" D Q
.. S $P(^BDGCTX(SRV,1,CURR,0),U,2)=$P($G(^BDGCTX(SRV,1,PREV,0)),U,2)
.. S $P(^BDGCTX(SRV,1,CURR,0),U,12)=$P($G(^BDGCTX(SRV,1,PREV,0)),U,12)
. ;
. ; else, perform calculations
. S REMA=$P($G(^BDGCTX(SRV,1,PREV,0)),U,2) ;prev adults remaining
. S REMP=$P($G(^BDGCTX(SRV,1,PREV,0)),U,12) ;prev peds remaining
. S N=$G(^BDGCTX(SRV,1,CURR,0))
. S NEWA=REMA+$P(N,U,3)-$P(N,U,4)+$P(N,U,5)-$P(N,U,6)-$P(N,U,7)
. S NEWP=REMP+$P(N,U,13)-$P(N,U,14)+$P(N,U,15)-$P(N,U,16)-$P(N,U,17)
. ;
. S $P(^BDGCTX(SRV,1,CURR,0),U,2)=NEWA
. S $P(^BDGCTX(SRV,1,CURR,0),U,12)=NEWP
;
WARD ; loop through wards and fill in patients remaining
NEW WARD,REM,REMA,REMP,NEW,NEWA,NEWP,N,N1
S WARD=0 F S WARD=$O(^BDGCWD(WARD)) Q:'WARD D
. ;
. ; if no activity, bring old numbers forward
. I $P(^BDGCWD(WARD,1,CURR,0),U,2,99)="" D
.. S $P(^BDGCWD(WARD,1,CURR,0),U,2)=$P($G(^BDGCWD(WARD,1,PREV,0)),U,2)
. ;
. ; else, perform calculations
. E D
.. S REM=$P($G(^BDGCWD(WARD,1,PREV,0)),U,2) ;prev remaining
.. S N=$G(^BDGCWD(WARD,1,CURR,0))
.. S NEW=REM+$P(N,U,3)-$P(N,U,4)+$P(N,U,5)-$P(N,U,6)-$P(N,U,7)
.. S $P(^BDGCWD(WARD,1,CURR,0),U,2)=NEW ;new remaining total
. ;
. ; for services within wards
. S SRV=0 F S SRV=$O(^BDGCWD(WARD,1,PREV,1,SRV)) Q:'SRV D
.. ;
.. ; if no activity for service, bring numbers forward
.. I '$D(^BDGCWD(WARD,1,CURR,1,SRV,0)) D Q
... S $P(^BDGCWD(WARD,1,CURR,1,0),U,3,4)=SRV_U_($P(^BDGCWD(WARD,1,CURR,1,0),U,4)+1)
... S ^BDGCWD(WARD,1,CURR,1,SRV,0)=SRV_U_(+$P(^BDGCWD(WARD,1,PREV,1,SRV,0),U,2))
... S $P(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=+$P(^BDGCWD(WARD,1,PREV,1,SRV,0),U,12) ;peds remaining
.. ;
.. ; else, perform calculations
.. S REMA=$P($G(^BDGCWD(WARD,1,PREV,1,SRV,0)),U,2) ;prev adults
.. S REMP=$P($G(^BDGCWD(WARD,1,PREV,1,SRV,0)),U,12) ;prev peds
.. S N=$G(^BDGCWD(WARD,1,CURR,1,SRV,0))
.. S NEWA=REMA+$P(N,U,3)-$P(N,U,4)+$P(N,U,5)-$P(N,U,6)-$P(N,U,7)
.. S NEWP=REMP+$P(N,U,13)-$P(N,U,14)+$P(N,U,15)-$P(N,U,16)-$P(N,U,17)
.. ;
.. S $P(^BDGCWD(WARD,1,CURR,1,SRV,0),U,2)=NEWA
.. S $P(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=NEWP
. ;
. ; for services added to ward for the first time, no prev date
. S SRV=0 F S SRV=$O(^BDGCWD(WARD,1,CURR,1,SRV)) Q:'SRV D
.. Q:$D(^BDGCWD(WARD,1,PREV,1,SRV)) ;only first timers
.. ;
.. ; perform calculations
.. S N=$G(^BDGCWD(WARD,1,CURR,1,SRV,0))
.. S NEWA=$P(N,U,3)-$P(N,U,4)+$P(N,U,5)-$P(N,U,6)-$P(N,U,7)
.. S NEWP=$P(N,U,13)-$P(N,U,14)+$P(N,U,15)-$P(N,U,16)-$P(N,U,17)
.. ;
.. S $P(^BDGCWD(WARD,1,CURR,1,SRV,0),U,2)=NEWA
.. S $P(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=NEWP
Q
BDGAD5 ; IHS/ANMC/LJF - A&D PTS REMAINING ;
+1 ;;5.3;PIMS;**1009,1012**;APR 26, 2002
+2 ;
+3 ;cmi/anch/maw 2/11/2008 added fix in SERV PATCH 1009
+4 ;
+5 NEW PREV,CURR
+6 SET CURR=BDGT
+7 ;previous day
SET PREV=$$FMADD^XLFDT(CURR,-1)
+8 ;
SERV ; loop through services and fill in patients remaining
+1 NEW SRV,REMA,REMP,NEWA,NEWP,N
+2 SET SRV=0
FOR
SET SRV=$ORDER(^BDGCTX(SRV))
IF 'SRV
QUIT
Begin DoDot:1
+3 ;cmi/maw 2/11/2008 quit if no current date for service PATCH 1009
IF '$DATA(^BDGCTX(SRV,1,PREV,0))
QUIT
+4 ;cmi/maw 4/23/2010 quit if no current date for service PATCH 1012
IF '$DATA(^BDGCTX(SRV,1,CURR,0))
QUIT
+5 ;
+6 ; if no activity, bring old numbers forward
+7 IF $PIECE(^BDGCTX(SRV,1,CURR,0),U,2,99)=""
Begin DoDot:2
+8 SET $PIECE(^BDGCTX(SRV,1,CURR,0),U,2)=$PIECE($GET(^BDGCTX(SRV,1,PREV,0)),U,2)
+9 SET $PIECE(^BDGCTX(SRV,1,CURR,0),U,12)=$PIECE($GET(^BDGCTX(SRV,1,PREV,0)),U,12)
End DoDot:2
QUIT
+10 ;
+11 ; else, perform calculations
+12 ;prev adults remaining
SET REMA=$PIECE($GET(^BDGCTX(SRV,1,PREV,0)),U,2)
+13 ;prev peds remaining
SET REMP=$PIECE($GET(^BDGCTX(SRV,1,PREV,0)),U,12)
+14 SET N=$GET(^BDGCTX(SRV,1,CURR,0))
+15 SET NEWA=REMA+$PIECE(N,U,3)-$PIECE(N,U,4)+$PIECE(N,U,5)-$PIECE(N,U,6)-$PIECE(N,U,7)
+16 SET NEWP=REMP+$PIECE(N,U,13)-$PIECE(N,U,14)+$PIECE(N,U,15)-$PIECE(N,U,16)-$PIECE(N,U,17)
+17 ;
+18 SET $PIECE(^BDGCTX(SRV,1,CURR,0),U,2)=NEWA
+19 SET $PIECE(^BDGCTX(SRV,1,CURR,0),U,12)=NEWP
End DoDot:1
+20 ;
WARD ; loop through wards and fill in patients remaining
+1 NEW WARD,REM,REMA,REMP,NEW,NEWA,NEWP,N,N1
+2 SET WARD=0
FOR
SET WARD=$ORDER(^BDGCWD(WARD))
IF 'WARD
QUIT
Begin DoDot:1
+3 ;
+4 ; if no activity, bring old numbers forward
+5 IF $PIECE(^BDGCWD(WARD,1,CURR,0),U,2,99)=""
Begin DoDot:2
+6 SET $PIECE(^BDGCWD(WARD,1,CURR,0),U,2)=$PIECE($GET(^BDGCWD(WARD,1,PREV,0)),U,2)
End DoDot:2
+7 ;
+8 ; else, perform calculations
+9 IF '$TEST
Begin DoDot:2
+10 ;prev remaining
SET REM=$PIECE($GET(^BDGCWD(WARD,1,PREV,0)),U,2)
+11 SET N=$GET(^BDGCWD(WARD,1,CURR,0))
+12 SET NEW=REM+$PIECE(N,U,3)-$PIECE(N,U,4)+$PIECE(N,U,5)-$PIECE(N,U,6)-$PIECE(N,U,7)
+13 ;new remaining total
SET $PIECE(^BDGCWD(WARD,1,CURR,0),U,2)=NEW
End DoDot:2
+14 ;
+15 ; for services within wards
+16 SET SRV=0
FOR
SET SRV=$ORDER(^BDGCWD(WARD,1,PREV,1,SRV))
IF 'SRV
QUIT
Begin DoDot:2
+17 ;
+18 ; if no activity for service, bring numbers forward
+19 IF '$DATA(^BDGCWD(WARD,1,CURR,1,SRV,0))
Begin DoDot:3
+20 SET $PIECE(^BDGCWD(WARD,1,CURR,1,0),U,3,4)=SRV_U_($PIECE(^BDGCWD(WARD,1,CURR,1,0),U,4)+1)
+21 SET ^BDGCWD(WARD,1,CURR,1,SRV,0)=SRV_U_(+$PIECE(^BDGCWD(WARD,1,PREV,1,SRV,0),U,2))
+22 ;peds remaining
SET $PIECE(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=+$PIECE(^BDGCWD(WARD,1,PREV,1,SRV,0),U,12)
End DoDot:3
QUIT
+23 ;
+24 ; else, perform calculations
+25 ;prev adults
SET REMA=$PIECE($GET(^BDGCWD(WARD,1,PREV,1,SRV,0)),U,2)
+26 ;prev peds
SET REMP=$PIECE($GET(^BDGCWD(WARD,1,PREV,1,SRV,0)),U,12)
+27 SET N=$GET(^BDGCWD(WARD,1,CURR,1,SRV,0))
+28 SET NEWA=REMA+$PIECE(N,U,3)-$PIECE(N,U,4)+$PIECE(N,U,5)-$PIECE(N,U,6)-$PIECE(N,U,7)
+29 SET NEWP=REMP+$PIECE(N,U,13)-$PIECE(N,U,14)+$PIECE(N,U,15)-$PIECE(N,U,16)-$PIECE(N,U,17)
+30 ;
+31 SET $PIECE(^BDGCWD(WARD,1,CURR,1,SRV,0),U,2)=NEWA
+32 SET $PIECE(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=NEWP
End DoDot:2
+33 ;
+34 ; for services added to ward for the first time, no prev date
+35 SET SRV=0
FOR
SET SRV=$ORDER(^BDGCWD(WARD,1,CURR,1,SRV))
IF 'SRV
QUIT
Begin DoDot:2
+36 ;only first timers
IF $DATA(^BDGCWD(WARD,1,PREV,1,SRV))
QUIT
+37 ;
+38 ; perform calculations
+39 SET N=$GET(^BDGCWD(WARD,1,CURR,1,SRV,0))
+40 SET NEWA=$PIECE(N,U,3)-$PIECE(N,U,4)+$PIECE(N,U,5)-$PIECE(N,U,6)-$PIECE(N,U,7)
+41 SET NEWP=$PIECE(N,U,13)-$PIECE(N,U,14)+$PIECE(N,U,15)-$PIECE(N,U,16)-$PIECE(N,U,17)
+42 ;
+43 SET $PIECE(^BDGCWD(WARD,1,CURR,1,SRV,0),U,2)=NEWA
+44 SET $PIECE(^BDGCWD(WARD,1,CURR,1,SRV,0),U,12)=NEWP
End DoDot:2
End DoDot:1
+45 QUIT
