APCLOS5.m

APCLOS5 ; IHS/CMI/LAB - RX ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 ;This Routine works with the Division of the Pharmacy

 ;Site and Prescription File.  The Related Institution

 ;field of the Pharmacy Site file contains the Facility

 ;Location IEN for each .01 Free Text Division Entries

 ;This routine checks hits against the location if the

 ;User has requested individual facility summaries.

 ;The Related Institution Field must be the Division

 ;itself, not the Primary Service Unit Facility.

 ;

RX ;

 S X1=APCLFYB,X2=-1 D C^%DTC S APCLSD=X_".9999",APCLED=APCLFYE,APCLOS="APCLOS" D PROC

 S X1=APCLPYB,X2=-1 D C^%DTC S APCLSD=X_".9999",APCLED=APCLPYE,APCLOS="APCLOSP" D PROC

 K APCLRX,APCLODAT,APCLSD,APCLED,APCLOS,APCLRX1,APCLPS,APCLDIV

 Q

 ;

PROC ;

 S APCLODAT=$O(^PSRX("AD",APCLSD)) Q:APCLODAT=""

 S APCLODAT=APCLSD F  S APCLODAT=$O(^PSRX("AD",APCLODAT)) Q:APCLODAT=""!((APCLODAT\1)>APCLED)  D PROC1

 Q

PROC1 ;

 S APCLRX="" F  S APCLRX=$O(^PSRX("AD",APCLODAT,APCLRX)) Q:APCLRX'=+APCLRX  D PROC2

 Q

PROC2 ;

 Q:$$DEMO^APCLUTL($P(^PSRX(APCLRX,0),U,2),$G(APCLDEMO))

 S APCLPS=$$VALI^XBDIQ1(52,APCLRX,20)

 Q:APCLPS=""

 S APCLDIV=$$VALI^XBDIQ1(59,APCLPS,100)

 Q:'$D(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLDIV))

 S APCLRX1="" F  S APCLRX1=$O(^PSRX("AD",APCLODAT,APCLRX,APCLRX1)) Q:APCLRX1=""  D PROC3

 Q

PROC3 ;

 G:APCLRX1>0 REFILL

 S ^("RXNEW")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"RXNEW")):(+^("RXNEW")+1),1:1)

 ;

 Q

REFILL ;

 S ^("RXREFILLS")=$S($D(^XTMP(APCLOS,APCLJOB,APCLBTH,"RXREFILLS")):(+^("RXREFILLS")+1),1:1)

 Q

APCLOS5   ; IHS/CMI/LAB - RX ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3       ;This Routine works with the Division of the Pharmacy

 +4       ;Site and Prescription File.  The Related Institution

 +5       ;field of the Pharmacy Site file contains the Facility

 +6       ;Location IEN for each .01 Free Text Division Entries

 +7       ;This routine checks hits against the location if the

 +8       ;User has requested individual facility summaries.

 +9       ;The Related Institution Field must be the Division

 +10      ;itself, not the Primary Service Unit Facility.

 +11      ;

RX        ;

 +1        SET X1=APCLFYB

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X_".9999"

           SET APCLED=APCLFYE

           SET APCLOS="APCLOS"

           DO PROC

 +2        SET X1=APCLPYB

           SET X2=-1

           DO C^%DTC

           SET APCLSD=X_".9999"

           SET APCLED=APCLPYE

           SET APCLOS="APCLOSP"

           DO PROC

 +3        KILL APCLRX,APCLODAT,APCLSD,APCLED,APCLOS,APCLRX1,APCLPS,APCLDIV

 +4        QUIT 

 +5       ;

PROC      ;

 +1        SET APCLODAT=$ORDER(^PSRX("AD",APCLSD))

           IF APCLODAT=""

               QUIT 

 +2        SET APCLODAT=APCLSD

           FOR 

               SET APCLODAT=$ORDER(^PSRX("AD",APCLODAT))

               IF APCLODAT=""!((APCLODAT\1)>APCLED)

                   QUIT 

               DO PROC1

 +3        QUIT 

PROC1     ;

 +1        SET APCLRX=""

           FOR 

               SET APCLRX=$ORDER(^PSRX("AD",APCLODAT,APCLRX))

               IF APCLRX'=+APCLRX

                   QUIT 

               DO PROC2

 +2        QUIT 

PROC2     ;

 +1        IF $$DEMO^APCLUTL($PIECE(^PSRX(APCLRX,0),U,2),$GET(APCLDEMO))

               QUIT 

 +2        SET APCLPS=$$VALI^XBDIQ1(52,APCLRX,20)

 +3        IF APCLPS=""

               QUIT 

 +4        SET APCLDIV=$$VALI^XBDIQ1(59,APCLPS,100)

 +5        IF '$DATA(^XTMP("APCLSU",APCLJOB,APCLBTH,APCLDIV))

               QUIT 

 +6        SET APCLRX1=""

           FOR 

               SET APCLRX1=$ORDER(^PSRX("AD",APCLODAT,APCLRX,APCLRX1))

               IF APCLRX1=""

                   QUIT 

               DO PROC3

 +7        QUIT 

PROC3     ;

 +1        IF APCLRX1>0

               GOTO REFILL

 +2        SET ^("RXNEW")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"RXNEW")):(+^("RXNEW")+1),1:1)

 +3       ;

 +4        QUIT 

REFILL    ;

 +1        SET ^("RXREFILLS")=$SELECT($DATA(^XTMP(APCLOS,APCLJOB,APCLBTH,"RXREFILLS")):(+^("RXREFILLS")+1),1:1)

 +2        QUIT