Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSGWUAS

PSGWUAS.m

Go to the documentation of this file.
  1. 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
  1. ;CHECK FOR NON-PHARMACY ITEMS IN AOUs
  1. D ^PSGWCAD3
  1. ;ROUTINE LOOPS THROUGH ^PSI(58.5,"AMIS" CROSS REFERENCE, CALCULATES AND STORES AMIS DATA IN ^PSI(58.5,.
  1. D:$O(^PSI(58.5,"AMISERR",0)) ERRCHK S CURDT=0
  1. ;CALL TO DRUG ACCOUNTABILITY TO RECORD DISPENSING
  1. 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
  1. L +^PSI(58.5,"AMIS")
  1. DTLP S CURDT=$O(^PSI(58.5,"AMIS",CURDT)) G:CURDT="" END S ADT=0
  1. ADT S ADT=$O(^PSI(58.5,"AMIS",CURDT,ADT)) G:'ADT DTLP S PSGWADT=$P(ADT,"."),PSGWCAT=0
  1. CAT S PSGWCAT=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT)) G:PSGWCAT="" ADT S PSGWAOU=0
  1. AOU S PSGWAOU=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU)) G:'PSGWAOU CAT S PSGWDN=0 S AOU=PSGWAOU D AOUCHK
  1. DRLP S PSGWDN=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN)) G:'PSGWDN AOU S PSGWQD=""
  1. QDLP S PSGWQD=$O(^PSI(58.5,"AMIS",CURDT,ADT,PSGWCAT,PSGWAOU,PSGWDN,PSGWQD)) G:'PSGWQD DRLP
  1. 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
  1. 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
  1. END D:$O(ERR1(0)) MAIL^PSGWCAD1 D:$O(ERR2(0)) MAIL^PSGWCAD2
  1. D NOW^%DTC S PSGWUPDT=%,DIE="^PS(59.7,",DA=1,DR="50///"_PSGWUPDT D ^DIE K DIE
  1. 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
  1. AOUCHK ; Check AOU for SITE - ERR=1 => Missing Inp. Site ERR=2 => Invalid Inp. Site
  1. 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
  1. 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
  1. ;
  1. INV ;SET THE COMPILE FLAG FOR SUBFILE 58.12 - INVENTORY
  1. 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
  1. ;
  1. RET ;SET THE COMPILE FLAG FOR SUBFILE 58.15 - RETURNS
  1. 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
  1. ;
  1. OND ;SET THE COMPILE FLAG FOR SUBFILE 58.28 - ON-DEMANDS
  1. 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
  1. Q
  1. ERRCHK ;Check "ERR" nodes for Site Data for AOUs
  1. 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
  1. K AOU,HH,ADT,CAT,DRG,QD,LL,SITE Q
  1. SET1 ;
  1. 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
  1. Q
  1. SET2 ;
  1. 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)
  1. Q