ADEGRL33.m

ADEGRL33 ; IHS/HQT/MJL - GET TX HX ;  [ 11/06/2000  2:07 PM ]

 ;;6.0;ADE;**2,4**;NOVEMBER 2000

 ;STORE PROCEDURE HX IN ARRAYS

 ;ADEHXC(CODE,DATE) AND ADEHXO(OPSITE,CODE,DATE)

 ;^TMP("ADEHXF",$J,CODE,DATE)=QTY^FACILITY

EN1 ;EP

 K ^TMP("ADEHXF",$J)

 N ADEDFN,ADEHVFM,ADEHX,ADENOD,ADECOD,ADELOE,ADENOD0

 Q:'$D(^ADEPCD("B",ADEPAT))

 S ADEDFN=0 F  S ADEDFN=$O(^ADEPCD("B",ADEPAT,ADEDFN)) Q:'+ADEDFN  D GET

 Q

 K ADEHVFM,ADEHX,ADELOE,ADENOD0 ;*NE

 ;

GETHX(ADEPAT)      ;EP

 ;Sets ADEHX* arrays for patient ADEPAT

 K ADEHXC,ADEHXO,ADEHXF

 K ^TMP("ADEHXF",$J)

 D EN1^ADEGRL33

 Q

 ;

GET Q:'$D(^ADEPCD(ADEDFN,0))

 S ADENOD0=^ADEPCD(ADEDFN,0)

 S ADEHVFM=$P(ADENOD0,U,2)

 S ADELOE=$P(ADENOD0,U,3)

 S ADEHX=0 F  S ADEHX=$O(^ADEPCD(ADEDFN,"ADA",ADEHX)) Q:'+ADEHX  D G1

 Q

G1 ;IHS/HMW ADEK Subroutine modified to increment ADEHXC( array

 ;by 1 for each code

 S ADENOD=^ADEPCD(ADEDFN,"ADA",ADEHX,0)

 Q:$P(ADENOD,U,5)]""

 S ADECOD=$P($G(^AUTTADA($P(ADENOD,U),0)),U)

 Q:ADECOD=""  Q:ADEHVFM=""

 I $P(ADENOD,U,2)]"" D  Q

 . S ADEHXO($P(ADENOD,U,2),ADECOD,ADEHVFM)=""

 . S:'$D(ADEHXC(ADECOD,ADEHVFM)) ADEHXC(ADECOD,ADEHVFM)=0

 . S:'$D(^TMP("ADEHXF",$J,ADECOD,ADEHVFM)) ^TMP("ADEHXF",$J,ADECOD,ADEHVFM)="0^"_ADELOE

 . S ADEHXC(ADECOD,ADEHVFM)=ADEHXC(ADECOD,ADEHVFM)+1

 . S $P(^TMP("ADEHXF",$J,ADECOD,ADEHVFM),U)=$P(^TMP("ADEHXF",$J,ADECOD,ADEHVFM),U)+1

 I $P(ADENOD,U,2)="" D  Q

 . S:'$D(ADEHXC(ADECOD,ADEHVFM)) ADEHXC(ADECOD,ADEHVFM)=0

 . S:'$D(^TMP("ADEHXF",$J,ADECOD,ADEHVFM)) ^TMP("ADEHXF",$J,ADECOD,ADEHVFM)="0^"_ADELOE

 . S ADEHXC(ADECOD,ADEHVFM)=ADEHXC(ADECOD,ADEHVFM)+1

 . S $P(^TMP("ADEHXF",$J,ADECOD,ADEHVFM),U)=$P(^TMP("ADEHXF",$J,ADECOD,ADEHVFM),U)+1

 . ;instead of +1 use +quantity

 . ;Otherwise, all codes with no opsite must have qty=1

 Q

ADEGRL33  ; IHS/HQT/MJL - GET TX HX ;  [ 11/06/2000  2:07 PM ]

 +1       ;;6.0;ADE;**2,4**;NOVEMBER 2000

 +2       ;STORE PROCEDURE HX IN ARRAYS

 +3       ;ADEHXC(CODE,DATE) AND ADEHXO(OPSITE,CODE,DATE)

 +4       ;^TMP("ADEHXF",$J,CODE,DATE)=QTY^FACILITY

EN1       ;EP

 +1        KILL ^TMP("ADEHXF",$JOB)

 +2        NEW ADEDFN,ADEHVFM,ADEHX,ADENOD,ADECOD,ADELOE,ADENOD0

 +3        IF '$DATA(^ADEPCD("B",ADEPAT))

               QUIT 

 +4        SET ADEDFN=0

           FOR 

               SET ADEDFN=$ORDER(^ADEPCD("B",ADEPAT,ADEDFN))

               IF '+ADEDFN

                   QUIT 

               DO GET

 +5        QUIT 

 +6       ;*NE

           KILL ADEHVFM,ADEHX,ADELOE,ADENOD0

 +7       ;

GETHX(ADEPAT) ;EP

 +1       ;Sets ADEHX* arrays for patient ADEPAT

 +2        KILL ADEHXC,ADEHXO,ADEHXF

 +3        KILL ^TMP("ADEHXF",$JOB)

 +4        DO EN1^ADEGRL33

 +5        QUIT 

 +6       ;

GET        IF '$DATA(^ADEPCD(ADEDFN,0))

               QUIT 

 +1        SET ADENOD0=^ADEPCD(ADEDFN,0)

 +2        SET ADEHVFM=$PIECE(ADENOD0,U,2)

 +3        SET ADELOE=$PIECE(ADENOD0,U,3)

 +4        SET ADEHX=0

           FOR 

               SET ADEHX=$ORDER(^ADEPCD(ADEDFN,"ADA",ADEHX))

               IF '+ADEHX

                   QUIT 

               DO G1

 +5        QUIT 

G1        ;IHS/HMW ADEK Subroutine modified to increment ADEHXC( array

 +1       ;by 1 for each code

 +2        SET ADENOD=^ADEPCD(ADEDFN,"ADA",ADEHX,0)

 +3        IF $PIECE(ADENOD,U,5)]""

               QUIT 

 +4        SET ADECOD=$PIECE($GET(^AUTTADA($PIECE(ADENOD,U),0)),U)

 +5        IF ADECOD=""

               QUIT 

           IF ADEHVFM=""

               QUIT 

 +6        IF $PIECE(ADENOD,U,2)]""

               Begin DoDot:1

 +7                SET ADEHXO($PIECE(ADENOD,U,2),ADECOD,ADEHVFM)=""

 +8                IF '$DATA(ADEHXC(ADECOD,ADEHVFM))

                       SET ADEHXC(ADECOD,ADEHVFM)=0

 +9                IF '$DATA(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM))

                       SET ^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM)="0^"_ADELOE

 +10               SET ADEHXC(ADECOD,ADEHVFM)=ADEHXC(ADECOD,ADEHVFM)+1

 +11               SET $PIECE(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM),U)=$PIECE(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM),U)+1

               End DoDot:1

               QUIT 

 +12       IF $PIECE(ADENOD,U,2)=""

               Begin DoDot:1

 +13               IF '$DATA(ADEHXC(ADECOD,ADEHVFM))

                       SET ADEHXC(ADECOD,ADEHVFM)=0

 +14               IF '$DATA(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM))

                       SET ^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM)="0^"_ADELOE

 +15               SET ADEHXC(ADECOD,ADEHVFM)=ADEHXC(ADECOD,ADEHVFM)+1

 +16               SET $PIECE(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM),U)=$PIECE(^TMP("ADEHXF",$JOB,ADECOD,ADEHVFM),U)+1

 +17      ;instead of +1 use +quantity

 +18      ;Otherwise, all codes with no opsite must have qty=1

               End DoDot:1

               QUIT 

 +19       QUIT