source: FOIAVistA/trunk/r/AUTO_REPLENISHMENT_WARD_STOCK-PSGW/PSGWUAS.m@ 1586

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