BDGAD5.m

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