- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWUAS 3279 printed Feb 18, 2025@23:06:38 Page 2
- 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