PSGWUAS ;BHAM ISC/PTD,CML-Update AMIS Stats File ; 08 Dec 93 / 9:00 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
;CHECK FOR NON-PHARMACY ITEMS IN AOUs
D ^PSGWCAD3
;ROUTINE LOOPS THROUGH ^PSI(58.5,"AMIS" CROSS REFERENCE, CALCULATES AND STORES AMIS DATA IN ^PSI(58.5,.
D:$O(^PSI(58.5,"AMISERR",0)) ERRCHK S CURDT=0
;CALL TO DRUG ACCOUNTABILITY TO RECORD DISPENSING
I $P($G(^PS(59.7,+$O(^PS(59.7,0)),70)),U,5),$D(^%ZOSF("TEST")) S X="PSARWS" X ^%ZOSF("TEST") K X I D ^PSARWS
L +^PSI(58.5,"AMIS")
DTLP S CURDT=$O(^PSI(58.5,"AMIS",CURDT)) G:CURDT="" END S ADT=0
ADT S ADT=$O(^PSI(58.5,"AMIS",CURDT,ADT)) G:'ADT DTLP S PSGWADT=$P(ADT,"."),PSGWCAT=0
CAT S PSGWCAT=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT)) G:PSGWCAT="" ADT S PSGWAOU=0
AOU S PSGWAOU=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU)) G:'PSGWAOU CAT S PSGWDN=0 S AOU=PSGWAOU D AOUCHK
DRLP S PSGWDN=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN)) G:'PSGWDN AOU S PSGWQD=""
QDLP S PSGWQD=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)) G:'PSGWQD DRLP
I ERR S ^PSI(58.5,"AMISERR",PSGWAOU,CURDT,ADT,PSGWCAT,PSGWDN,PSGWQD)="" K ^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD) G QDLP
D ^PSGWCAD D @$S(PSGWCAT="A":"INV",PSGWCAT="R":"RET",1:"OND") K ^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD) G QDLP
END D:$O(ERR1(0)) MAIL^PSGWCAD1 D:$O(ERR2(0)) MAIL^PSGWCAD2
D NOW^%DTC S PSGWUPDT=%,DIE="^PS(59.7,",DA=1,DR="50///"_PSGWUPDT D ^DIE K DIE
K CURDT,PSGWADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD,ADT,DRGDA,INVDA,VAR,CMPDT,PSGWUPDT,%,%I,%H,%Z,D0,DI,DA,DR,DIE,DQ,AOU,ERR,ERR1,ERR2,GOTIT,SITE,X,Y L -^PSI(58.5,"AMIS") Q
AOUCHK ; Check AOU for SITE - ERR=1 => Missing Inp. Site ERR=2 => Invalid Inp. Site
S ERR=0 I $D(^PSI(58.1,AOU,"SITE")),^("SITE") S SITE=^("SITE") I $D(^PS(59.4,SITE,0)),$P(^(0),"^",26) Q
S ERR=$S('$D(^PSI(58.1,AOU,"SITE")):1,'^("SITE"):1,1:2) S:ERR=1 ERR1(AOU)="" Q:ERR=1 S ERR2(AOU)="" Q
;
INV ;SET THE COMPILE FLAG FOR SUBFILE 58.12 - INVENTORY
Q:'$O(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0)) S DRGDA=$O(^(0)) Q:'$O(^PSI(58.19,"B",ADT,0)) S INVDA=$O(^(0)),$P(^PSI(58.1,PSGWAOU,1,DRGDA,1,INVDA,0),"^",4)=1 Q
;
RET ;SET THE COMPILE FLAG FOR SUBFILE 58.15 - RETURNS
Q:'$O(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0)) S DRGDA=$O(^(0)),$P(^PSI(58.1,PSGWAOU,1,DRGDA,3,PSGWADT,0),"^",4)=1 Q
;
OND ;SET THE COMPILE FLAG FOR SUBFILE 58.28 - ON-DEMANDS
Q:'$O(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0)) S DRGDA=$O(^(0)) F VAR=0:0 S VAR=$O(^PSI(58.1,PSGWAOU,1,DRGDA,5,VAR)) Q:'VAR S CMPDT=$P(^(VAR,0),"^") Q:CMPDT=PSGWADT I VAR'="" S $P(^PSI(58.1,PSGWAOU,1,DRGDA,5,VAR,0),"^",4)=1
Q
ERRCHK ;Check "ERR" nodes for Site Data for AOUs
Q:'$O(^PSI(58.5,"AMISERR",0)) F AOU=0:0 S AOU=$O(^PSI(58.5,"AMISERR",AOU)) Q:'AOU D AOUCHK I 'ERR D SET1
K AOU,HH,ADT,CAT,DRG,QD,LL,SITE Q
SET1 ;
S HH="" F LL=0:0 S HH=$O(^PSI(58.5,"AMISERR",AOU,HH)) Q:HH="" F ADT=0:0 S ADT=$O(^PSI(58.5,"AMISERR",AOU,HH,ADT)) Q:'ADT S CAT="" F LL=0:0 S CAT=$O(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT)) Q:CAT="" D SET2
Q
SET2 ;
F DRG=0:0 S DRG=$O(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG)) Q:'DRG F QD=-100000:0 S QD=$O(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG,QD)) Q:'QD S ^PSI(58.5,"AMIS",HH,ADT,CAT,AOU,DRG,QD)="" K ^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG,QD)
Q
PSGWUAS ;BHAM ISC/PTD,CML-Update AMIS Stats File ; 08 Dec 93 / 9:00 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 ;CHECK FOR NON-PHARMACY ITEMS IN AOUs
+3 DO ^PSGWCAD3
+4 ;ROUTINE LOOPS THROUGH ^PSI(58.5,"AMIS" CROSS REFERENCE, CALCULATES AND STORES AMIS DATA IN ^PSI(58.5,.
+5 IF $ORDER(^PSI(58.5,"AMISERR",0))
DO ERRCHK
SET CURDT=0
+6 ;CALL TO DRUG ACCOUNTABILITY TO RECORD DISPENSING
+7 IF $PIECE($GET(^PS(59.7,+$ORDER(^PS(59.7,0)),70)),U,5)
IF $DATA(^%ZOSF("TEST"))
SET X="PSARWS"
XECUTE ^%ZOSF("TEST")
KILL X
IF $TEST
DO ^PSARWS
+8 LOCK +^PSI(58.5,"AMIS")
DTLP SET CURDT=$ORDER(^PSI(58.5,"AMIS",CURDT))
IF CURDT=""
GOTO END
SET ADT=0
ADT SET ADT=$ORDER(^PSI(58.5,"AMIS",CURDT,ADT))
IF 'ADT
GOTO DTLP
SET PSGWADT=$PIECE(ADT,".")
SET PSGWCAT=0
CAT SET PSGWCAT=$ORDER(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT))
IF PSGWCAT=""
GOTO ADT
SET PSGWAOU=0
AOU SET PSGWAOU=$ORDER(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU))
IF 'PSGWAOU
GOTO CAT
SET PSGWDN=0
SET AOU=PSGWAOU
DO AOUCHK
DRLP SET PSGWDN=$ORDER(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN))
IF 'PSGWDN
GOTO AOU
SET PSGWQD=""
QDLP SET PSGWQD=$ORDER(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD))
IF 'PSGWQD
GOTO DRLP
+1 IF ERR
SET ^PSI(58.5,"AMISERR",PSGWAOU,CURDT,ADT,PSGWCAT,PSGWDN,PSGWQD)=""
KILL ^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)
GOTO QDLP
+2 DO ^PSGWCAD
DO @$SELECT(PSGWCAT="A":"INV",PSGWCAT="R":"RET",1:"OND")
KILL ^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)
GOTO QDLP
END IF $ORDER(ERR1(0))
DO MAIL^PSGWCAD1
IF $ORDER(ERR2(0))
DO MAIL^PSGWCAD2
+1 DO NOW^%DTC
SET PSGWUPDT=%
SET DIE="^PS(59.7,"
SET DA=1
SET DR="50///"_PSGWUPDT
DO ^DIE
KILL DIE
+2 KILL CURDT,PSGWADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD,ADT,DRGDA,INVDA,VAR,CMPDT,PSGWUPDT,%,%I,%H,%Z,D0,DI,DA,DR,DIE,DQ,AOU,ERR,ERR1,ERR2,GOTIT,SITE,X,Y
LOCK -^PSI(58.5,"AMIS")
QUIT
AOUCHK ; Check AOU for SITE - ERR=1 => Missing Inp. Site ERR=2 => Invalid Inp. Site
+1 SET ERR=0
IF $DATA(^PSI(58.1,AOU,"SITE"))
IF ^("SITE")
SET SITE=^("SITE")
IF $DATA(^PS(59.4,SITE,0))
IF $PIECE(^(0),"^",26)
QUIT
+2 SET ERR=$SELECT('$DATA(^PSI(58.1,AOU,"SITE")):1,'^("SITE"):1,1:2)
IF ERR=1
SET ERR1(AOU)=""
IF ERR=1
QUIT
SET ERR2(AOU)=""
QUIT
+3 ;
INV ;SET THE COMPILE FLAG FOR SUBFILE 58.12 - INVENTORY
+1 IF '$ORDER(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0))
QUIT
SET DRGDA=$ORDER(^(0))
IF '$ORDER(^PSI(58.19,"B",ADT,0))
QUIT
SET INVDA=$ORDER(^(0))
SET $PIECE(^PSI(58.1,PSGWAOU,1,DRGDA,1,INVDA,0),"^",4)=1
QUIT
+2 ;
RET ;SET THE COMPILE FLAG FOR SUBFILE 58.15 - RETURNS
+1 IF '$ORDER(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0))
QUIT
SET DRGDA=$ORDER(^(0))
SET $PIECE(^PSI(58.1,PSGWAOU,1,DRGDA,3,PSGWADT,0),"^",4)=1
QUIT
+2 ;
OND ;SET THE COMPILE FLAG FOR SUBFILE 58.28 - ON-DEMANDS
+1 IF '$ORDER(^PSI(58.1,PSGWAOU,1,"B",PSGWDN,0))
QUIT
SET DRGDA=$ORDER(^(0))
FOR VAR=0:0
SET VAR=$ORDER(^PSI(58.1,PSGWAOU,1,DRGDA,5,VAR))
IF 'VAR
QUIT
SET CMPDT=$PIECE(^(VAR,0),"^")
IF CMPDT=PSGWADT
QUIT
IF VAR'=""
SET $PIECE(^PSI(58.1,PSGWAOU,1,DRGDA,5,VAR,0),"^",4)=1
+2 QUIT
ERRCHK ;Check "ERR" nodes for Site Data for AOUs
+1 IF '$ORDER(^PSI(58.5,"AMISERR",0))
QUIT
FOR AOU=0:0
SET AOU=$ORDER(^PSI(58.5,"AMISERR",AOU))
IF 'AOU
QUIT
DO AOUCHK
IF 'ERR
DO SET1
+2 KILL AOU,HH,ADT,CAT,DRG,QD,LL,SITE
QUIT
SET1 ;
+1 SET HH=""
FOR LL=0:0
SET HH=$ORDER(^PSI(58.5,"AMISERR",AOU,HH))
IF HH=""
QUIT
FOR ADT=0:0
SET ADT=$ORDER(^PSI(58.5,"AMISERR",AOU,HH,ADT))
IF 'ADT
QUIT
SET CAT=""
FOR LL=0:0
SET CAT=$ORDER(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT))
IF CAT=""
QUIT
DO SET2
+2 QUIT
SET2 ;
+1 FOR DRG=0:0
SET DRG=$ORDER(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG))
IF 'DRG
QUIT
FOR QD=-100000:0
SET QD=$ORDER(^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG,QD))
IF 'QD
QUIT
SET ^PSI(58.5,"AMIS",HH,ADT,CAT,AOU,DRG,QD)=""
KILL ^PSI(58.5,"AMISERR",AOU,HH,ADT,CAT,DRG,QD)
+2 QUIT
