BDGILD61.m

BDGILD61 ; IHS/ANMC/LJF - TRANS BETWEEN FAC(CALC) ; 

 ;;5.3;PIMS;;APR 26, 2002

 ;

 ;

INIT ; -- initialize variables

 NEW DGCT,DGI1,DGI2,DGO1,DATE,DFN,IEN,ATYP,FAC,SERV,SRV,END,CA

 K ^TMP("BDGILD6A",$J),^TMP("BDGILD6D",$J)

 ; -- DGI1 & DGI2 = transfer in types

 S DGI1=$O(^DG(405.1,"AIHS1","A2",0))

 S DGI2=$O(^DG(405.1,"AIHS1","A3",0))

 ; -- DGO1 = transfer out type

 S DGO1=$O(^DG(405.1,"AIHS1","D2",0))

 ;

ADMT ; -- loop admissions

 S DATE=BDGBD-.0001,END=BDGED+.2400

 F  S DATE=$O(^DGPM("AMV1",DATE)) Q:'DATE!(DATE>END)  D

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

 .. S IEN=0 F  S IEN=$O(^DGPM("AMV1",DATE,DFN,IEN)) Q:'IEN  D

 ... ;

 ... S ATYP=$$GET1^DIQ(405,IEN,.04,"I")             ;admit type

 ... I (ATYP'=DGI1)&(ATYP'=DGI2) Q                  ;admit not transfer

 ... S FAC=$$GET1^DIQ(405,IEN,.05) S:FAC="" FAC="??"  ;transfer facility

 ... S SERV=$$ADMSRV^BDGF1(IEN,DFN)                 ;admit srv

 ... S SRV=$P($$ADMSRVC^BDGF1(IEN,DFN)," ")         ;admit srv abbrev

 ... S:SERV="" SERV="??" S:SRV="" SRV="??"

 ... ;

 ... ; increment counts

 ... I BDGTYP>1 D

 .... I '$D(DGCT(FAC,SERV)) S DGCT(FAC,SERV)=1

 .... S $P(DGCT(FAC,SERV),U)=$P(DGCT(FAC,SERV),U)+1

 ... ;

 ... ; store patient data for types 1 and 3

 ... I BDGTYP'=2 S ^TMP("BDGILD6A",$J,DATE,SRV,FAC,IEN)=DFN

 ;

DSCH ; -- loop discharges

 S DATE=BDGBD-.0001,END=BDGED+.2400

 F  S DATE=$O(^DGPM("AMV3",DATE)) Q:'DATE!(DATE>END)  D

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

 .. S IEN=0 F  S IEN=$O(^DGPM("AMV3",DATE,DFN,IEN)) Q:'IEN  D

 ... ;

 ... I $$GET1^DIQ(405,IEN,.04,"I")'=DGO1 Q         ;disch not transfer

 ... S FAC=$$GET1^DIQ(405,IEN,.05) S:FAC="" FAC="??"  ;transfer facility

 ... S CA=$$GET1^DIQ(405,IEN,.14,"I")              ;corresp admission

 ... S SERV=$$LASTSRVN^BDGF1(CA,DFN)            ;disch serv abbrev

 ... S SRV=$P($$LASTSRVC^BDGF1(CA,DFN)," ")       ;disch serv abbrev

 ... S:SERV="" SERV="??" S:SRV="" SRV="??"

 ... ;

 ... ; increment counts

 ... I BDGTYP>1 D

 ... I '$D(DGCT(FAC,SERV)) S DGCT(FAC,SERV)="^1"

 ... S $P(DGCT(FAC,SERV),U,2)=$P(DGCT(FAC,SERV),U,2)+1

 ... ;

 ... ; store patient data for types 1 & 3

 ... I BDGTYP'=2 S ^TMP("BDGILD6D",$J,DATE,SRV,FAC,IEN)=DFN

 ;

 D ^BDGILD62 Q

BDGILD61  ; IHS/ANMC/LJF - TRANS BETWEEN FAC(CALC) ; 

 +1       ;;5.3;PIMS;;APR 26, 2002

 +2       ;

 +3       ;

INIT      ; -- initialize variables

 +1        NEW DGCT,DGI1,DGI2,DGO1,DATE,DFN,IEN,ATYP,FAC,SERV,SRV,END,CA

 +2        KILL ^TMP("BDGILD6A",$JOB),^TMP("BDGILD6D",$JOB)

 +3       ; -- DGI1 & DGI2 = transfer in types

 +4        SET DGI1=$ORDER(^DG(405.1,"AIHS1","A2",0))

 +5        SET DGI2=$ORDER(^DG(405.1,"AIHS1","A3",0))

 +6       ; -- DGO1 = transfer out type

 +7        SET DGO1=$ORDER(^DG(405.1,"AIHS1","D2",0))

 +8       ;

ADMT      ; -- loop admissions

 +1        SET DATE=BDGBD-.0001

           SET END=BDGED+.2400

 +2        FOR 

               SET DATE=$ORDER(^DGPM("AMV1",DATE))

               IF 'DATE!(DATE>END)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DGPM("AMV1",DATE,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IEN=0

                           FOR 

                               SET IEN=$ORDER(^DGPM("AMV1",DATE,DFN,IEN))

                               IF 'IEN

                                   QUIT 

                               Begin DoDot:3

 +5       ;

 +6       ;admit type

                                   SET ATYP=$$GET1^DIQ(405,IEN,.04,"I")

 +7       ;admit not transfer

                                   IF (ATYP'=DGI1)&(ATYP'=DGI2)

                                       QUIT 

 +8       ;transfer facility

                                   SET FAC=$$GET1^DIQ(405,IEN,.05)

                                   IF FAC=""

                                       SET FAC="??"

 +9       ;admit srv

                                   SET SERV=$$ADMSRV^BDGF1(IEN,DFN)

 +10      ;admit srv abbrev

                                   SET SRV=$PIECE($$ADMSRVC^BDGF1(IEN,DFN)," ")

 +11                               IF SERV=""

                                       SET SERV="??"

                                   IF SRV=""

                                       SET SRV="??"

 +12      ;

 +13      ; increment counts

 +14                               IF BDGTYP>1

                                       Begin DoDot:4

 +15                                       IF '$DATA(DGCT(FAC,SERV))

                                               SET DGCT(FAC,SERV)=1

 +16                                       SET $PIECE(DGCT(FAC,SERV),U)=$PIECE(DGCT(FAC,SERV),U)+1

                                       End DoDot:4

 +17      ;

 +18      ; store patient data for types 1 and 3

 +19                               IF BDGTYP'=2

                                       SET ^TMP("BDGILD6A",$JOB,DATE,SRV,FAC,IEN)=DFN

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +20      ;

DSCH      ; -- loop discharges

 +1        SET DATE=BDGBD-.0001

           SET END=BDGED+.2400

 +2        FOR 

               SET DATE=$ORDER(^DGPM("AMV3",DATE))

               IF 'DATE!(DATE>END)

                   QUIT 

               Begin DoDot:1

 +3                SET DFN=0

                   FOR 

                       SET DFN=$ORDER(^DGPM("AMV3",DATE,DFN))

                       IF 'DFN

                           QUIT 

                       Begin DoDot:2

 +4                        SET IEN=0

                           FOR 

                               SET IEN=$ORDER(^DGPM("AMV3",DATE,DFN,IEN))

                               IF 'IEN

                                   QUIT 

                               Begin DoDot:3

 +5       ;

 +6       ;disch not transfer

                                   IF $$GET1^DIQ(405,IEN,.04,"I")'=DGO1

                                       QUIT 

 +7       ;transfer facility

                                   SET FAC=$$GET1^DIQ(405,IEN,.05)

                                   IF FAC=""

                                       SET FAC="??"

 +8       ;corresp admission

                                   SET CA=$$GET1^DIQ(405,IEN,.14,"I")

 +9       ;disch serv abbrev

                                   SET SERV=$$LASTSRVN^BDGF1(CA,DFN)

 +10      ;disch serv abbrev

                                   SET SRV=$PIECE($$LASTSRVC^BDGF1(CA,DFN)," ")

 +11                               IF SERV=""

                                       SET SERV="??"

                                   IF SRV=""

                                       SET SRV="??"

 +12      ;

 +13      ; increment counts

 +14                               IF BDGTYP>1

                                       Begin DoDot:4

                                       End DoDot:4

 +15                               IF '$DATA(DGCT(FAC,SERV))

                                       SET DGCT(FAC,SERV)="^1"

 +16                               SET $PIECE(DGCT(FAC,SERV),U,2)=$PIECE(DGCT(FAC,SERV),U,2)+1

 +17      ;

 +18      ; store patient data for types 1 & 3

 +19                               IF BDGTYP'=2

                                       SET ^TMP("BDGILD6D",$JOB,DATE,SRV,FAC,IEN)=DFN

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +20      ;

 +21       DO ^BDGILD62

           QUIT