- 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
