BDGAD2.m

BDGAD2 ; IHS/ANMC/LJF - A&D WARD TRANSFERS ;  [ 02/10/2005  4:05 PM ]

 ;;5.3;PIMS;**1001,1002,1012,1019**;APR 26, 2002;Build 3

 ;

LOOP ;--loop ward transfers

 NEW DGDT,DFN,IFN

 S DGDT=DGBEG

 F  S DGDT=$O(^DGPM("AMV2",DGDT)) Q:'DGDT!(DGDT>DGEND)  D

 . S DFN=0 F  S DFN=$O(^DGPM("AMV2",DGDT,DFN)) Q:'DFN  D

 .. S IFN=0 F  S IFN=$O(^DGPM("AMV2",DGDT,DFN,IFN)) Q:'IFN  D GATHER

 Q

 ;

GATHER ; gather info on ward transfers and put counts into arrays

 NEW ADM,ADULT,NEWWD,OLDWD,OLDSV,OLDSVN,NEWSV,NEWSVN,X,NAME,LOS

 S ADM=$P(^DGPM(IFN,0),U,14)                                 ;admit ien

 S ADULT=$S($$AGE<$$ADULT^BDGPAR:0,1:1)              ;1=adult, 0=peds

 ;

 ;S NEWWD=$P($G(^DGPM(IFN,0)),U,6) I 'NEWWD S NEWWD="??"        ;new ward  cmi/maw 4/23/2010 orig line

 S NEWWD=$P($G(^DGPM(IFN,0)),U,6) Q:'NEWWD        ;new ward  cmi/maw 4/23/2010 new ling

 S OLDWD=$P($G(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6)  ;old ward

 Q:'$G(OLDWD)  ;cmi/maw 4/23/2010 if old ward is blank patch 1012

 ;

 S OLDSV=$P(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9)  ;old srv

 Q:'$G(OLDSV)  ;cmi/maw 4/23/2010 if old service is blank PATCH 1012

 S X=$O(^DGPM("AMV6",DGDT,DFN,0))

 S NEWSV=$S('X:OLDSV,X:$P($G(^DGPM(X,0)),U,9),1:OLDSV)    ;new srv

 ;IHS/ITSC/WAR 1/21/2005 PATCH #1002 Added next line, defensive code for Pc9 being NULL (only a bed change on transfer record)

 ; Interward change - has no ward change, nor srv change

 I 'NEWSV S NEWSV=OLDSV

 S OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)

 S NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)

 ;

 S LOS=$$FMDIFF^XLFDT(DGDT,+$G(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)))

 ;

 ;  collect patient data for report

 S NAME=$$GET1^DIQ(2,DFN,.01)

 Q:$$DEMO^APCLUTL(DFN,"E")  ;ihs/cmi/maw patch 1019

 S ^TMP("BDGAD",$J,"WARD",NAME,DFN,IFN)=OLDWD_U_NEWWD

 I OLDSV'=NEWSV S ^TMP("BDGAD",$J,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV   ;IHS/ITSC/LJF 7/7/2004 PATCH #1001

 Q:$G(BDGREP)                              ;reprint, not recalculating

 ;

 ; -- increment counts in ADT Census files

 ; --- transfer in to new ward

 S $P(^BDGCWD(NEWWD,1,BDGT,0),U,5)=$P($G(^BDGCWD(NEWWD,1,BDGT,0)),U,5)+1

 ;

 ; --- transfer in for service within ward by age

 ; ---- set zero node if needed

 I '$D(^BDGCWD(NEWWD,1,BDGT,1,NEWSV)) D

 . S ^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)=NEWSV

 . S $P(^BDGCWD(NEWWD,1,BDGT,1,0),U,3,4)=NEWSV_U_($P(^BDGCWD(NEWWD,1,BDGT,1,0),U,4)+1)

 ;

 I '$D(^BDGCTX(NEWSV,1,BDGT,0)) D

 . S ^BDGCTX(NEWSV,1,BDGT,0)=BDGT

 I ADULT D

 . S $P(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,5)=$P($G(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,5)+1

 . I NEWSV'=OLDSV S $P(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1

 I 'ADULT D

 . S $P(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,15)=$P($G(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,15)+1

 . I NEWSV'=OLDSV S $P(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$P($G(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1

 ;

 ;

 ; --- transfer out of old ward

 S $P(^BDGCWD(OLDWD,1,BDGT,0),U,6)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,6)+1

 ;  ---- increment LOS for old ward

 S $P(^BDGCWD(OLDWD,1,BDGT,0),U,9)=$P($G(^BDGCWD(OLDWD,1,BDGT,0)),U,9)+LOS

 ;

 ; --- increment transfer out for service with in ward by age

 ; ---- set zero node if needed

 I '$D(^BDGCWD(OLDWD,1,BDGT,1,OLDSV)) D

 . S ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV

 . S $P(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($P(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)

 ;

 I ADULT D

 . S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,6)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,6)+1

 . S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,9)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,9)+LOS

 . I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1

 . I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS

 ;

 I 'ADULT D

 . S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,16)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,16)+1

 . S $P(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,19)=$P($G(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,19)+LOS

 . I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1

 . I OLDSV'=NEWSV S $P(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$P($G(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS

 ;

 Q

 ;

AGE() ;--age at admit

 NEW X,X1,X2

 S X1=+$G(^DGPM(ADM,0))                  ;admit date

 S X2=$P($G(^DPT(DFN,0)),U,3) D ^%DTC    ;date of birth

 Q:'X "" Q X\365.25

 ;

BDGAD2    ; IHS/ANMC/LJF - A&D WARD TRANSFERS ;  [ 02/10/2005  4:05 PM ]

 +1       ;;5.3;PIMS;**1001,1002,1012,1019**;APR 26, 2002;Build 3

 +2       ;

LOOP      ;--loop ward transfers

 +1        NEW DGDT,DFN,IFN

 +2        SET DGDT=DGBEG

 +3        FOR 

               SET DGDT=$ORDER(^DGPM("AMV2",DGDT))

               IF 'DGDT!(DGDT>DGEND)

                   QUIT 

               Begin DoDot:1

 +4                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DGPM("AMV2",DGDT,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +5                        SET IFN=0

                           FOR 

                               SET IFN=$ORDER(^DGPM("AMV2",DGDT,DFN,IFN))

                               IF 'IFN

                                   QUIT 

                               DO GATHER

                       End DoDot:2

               End DoDot:1

 +6        QUIT 

 +7       ;

GATHER    ; gather info on ward transfers and put counts into arrays

 +1        NEW ADM,ADULT,NEWWD,OLDWD,OLDSV,OLDSVN,NEWSV,NEWSVN,X,NAME,LOS

 +2       ;admit ien

           SET ADM=$PIECE(^DGPM(IFN,0),U,14)

 +3       ;1=adult, 0=peds

           SET ADULT=$SELECT($$AGE<$$ADULT^BDGPAR:0,1:1)

 +4       ;

 +5       ;S NEWWD=$P($G(^DGPM(IFN,0)),U,6) I 'NEWWD S NEWWD="??"        ;new ward  cmi/maw 4/23/2010 orig line

 +6       ;new ward  cmi/maw 4/23/2010 new ling

           SET NEWWD=$PIECE($GET(^DGPM(IFN,0)),U,6)

           IF 'NEWWD

               QUIT 

 +7       ;old ward

           SET OLDWD=$PIECE($GET(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)),U,6)

 +8       ;cmi/maw 4/23/2010 if old ward is blank patch 1012

           IF '$GET(OLDWD)

               QUIT 

 +9       ;

 +10      ;old srv

           SET OLDSV=$PIECE(^DGPM(+$$PRIORTXN^BDGF1(DGDT,ADM,DFN),0),U,9)

 +11      ;cmi/maw 4/23/2010 if old service is blank PATCH 1012

           IF '$GET(OLDSV)

               QUIT 

 +12       SET X=$ORDER(^DGPM("AMV6",DGDT,DFN,0))

 +13      ;new srv

           SET NEWSV=$SELECT('X:OLDSV,X:$PIECE($GET(^DGPM(X,0)),U,9),1:OLDSV)

 +14      ;IHS/ITSC/WAR 1/21/2005 PATCH #1002 Added next line, defensive code for Pc9 being NULL (only a bed change on transfer record)

 +15      ; Interward change - has no ward change, nor srv change

 +16       IF 'NEWSV

               SET NEWSV=OLDSV

 +17       SET OLDSVN=$$GET1^DIQ(45.7,OLDSV,.01)

 +18       SET NEWSVN=$$GET1^DIQ(45.7,NEWSV,.01)

 +19      ;

 +20       SET LOS=$$FMDIFF^XLFDT(DGDT,+$GET(^DGPM(+$$PRIORMVT^BDGF1(DGDT,ADM,DFN),0)))

 +21      ;

 +22      ;  collect patient data for report

 +23       SET NAME=$$GET1^DIQ(2,DFN,.01)

 +24      ;ihs/cmi/maw patch 1019

           IF $$DEMO^APCLUTL(DFN,"E")

               QUIT 

 +25       SET ^TMP("BDGAD",$JOB,"WARD",NAME,DFN,IFN)=OLDWD_U_NEWWD

 +26      ;IHS/ITSC/LJF 7/7/2004 PATCH #1001

           IF OLDSV'=NEWSV

               SET ^TMP("BDGAD",$JOB,"SERV",NAME,DFN,IFN)=OLDSV_U_NEWSV

 +27      ;reprint, not recalculating

           IF $GET(BDGREP)

               QUIT 

 +28      ;

 +29      ; -- increment counts in ADT Census files

 +30      ; --- transfer in to new ward

 +31       SET $PIECE(^BDGCWD(NEWWD,1,BDGT,0),U,5)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,0)),U,5)+1

 +32      ;

 +33      ; --- transfer in for service within ward by age

 +34      ; ---- set zero node if needed

 +35       IF '$DATA(^BDGCWD(NEWWD,1,BDGT,1,NEWSV))

               Begin DoDot:1

 +36               SET ^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)=NEWSV

 +37               SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,0),U,3,4)=NEWSV_U_($PIECE(^BDGCWD(NEWWD,1,BDGT,1,0),U,4)+1)

               End DoDot:1

 +38      ;

 +39       IF '$DATA(^BDGCTX(NEWSV,1,BDGT,0))

               Begin DoDot:1

 +40               SET ^BDGCTX(NEWSV,1,BDGT,0)=BDGT

               End DoDot:1

 +41       IF ADULT

               Begin DoDot:1

 +42               SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,5)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,5)+1

 +43               IF NEWSV'=OLDSV

                       SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,5)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,5)+1

               End DoDot:1

 +44       IF 'ADULT

               Begin DoDot:1

 +45               SET $PIECE(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0),U,15)=$PIECE($GET(^BDGCWD(NEWWD,1,BDGT,1,NEWSV,0)),U,15)+1

 +46               IF NEWSV'=OLDSV

                       SET $PIECE(^BDGCTX(NEWSV,1,BDGT,0),U,15)=$PIECE($GET(^BDGCTX(NEWSV,1,BDGT,0)),U,15)+1

               End DoDot:1

 +47      ;

 +48      ;

 +49      ; --- transfer out of old ward

 +50       SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,6)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,6)+1

 +51      ;  ---- increment LOS for old ward

 +52       SET $PIECE(^BDGCWD(OLDWD,1,BDGT,0),U,9)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,0)),U,9)+LOS

 +53      ;

 +54      ; --- increment transfer out for service with in ward by age

 +55      ; ---- set zero node if needed

 +56       IF '$DATA(^BDGCWD(OLDWD,1,BDGT,1,OLDSV))

               Begin DoDot:1

 +57               SET ^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)=OLDSV

 +58               SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,3,4)=OLDSV_U_($PIECE(^BDGCWD(OLDWD,1,BDGT,1,0),U,4)+1)

               End DoDot:1

 +59      ;

 +60       IF ADULT

               Begin DoDot:1

 +61               SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,6)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,6)+1

 +62               SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,9)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,9)+LOS

 +63               IF OLDSV'=NEWSV

                       SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,6)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,6)+1

 +64               IF OLDSV'=NEWSV

                       SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,9)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,9)+LOS

               End DoDot:1

 +65      ;

 +66       IF 'ADULT

               Begin DoDot:1

 +67               SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,16)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,16)+1

 +68               SET $PIECE(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0),U,19)=$PIECE($GET(^BDGCWD(OLDWD,1,BDGT,1,OLDSV,0)),U,19)+LOS

 +69               IF OLDSV'=NEWSV

                       SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,16)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,16)+1

 +70               IF OLDSV'=NEWSV

                       SET $PIECE(^BDGCTX(OLDSV,1,BDGT,0),U,19)=$PIECE($GET(^BDGCTX(OLDSV,1,BDGT,0)),U,19)+LOS

               End DoDot:1

 +71      ;

 +72       QUIT 

 +73      ;

AGE()     ;--age at admit

 +1        NEW X,X1,X2

 +2       ;admit date

           SET X1=+$GET(^DGPM(ADM,0))

 +3       ;date of birth

           SET X2=$PIECE($GET(^DPT(DFN,0)),U,3)

           DO ^%DTC

 +4        IF 'X

               QUIT ""

           QUIT X\365.25

 +5       ;