PSGWBGIN ;BHAM ISC/CML-AR/WS Item Inactivation ; 06 Aug 93 / 2:19 PM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
W !!,"You may inactivate a Stock Item for a single AOU,",!,"or enter ""^ALL"" to inactivate the Item in ALL AOUs.",!
K QFLG F QQ=0:0 Q:$D(QFLG) S ALL=1,DIC="^PSI(58.1,",DIC(0)="QEAM" D ^DIC K DIC Q:Y<0&(X'="^ALL") D:X'="^ALL" INACT2 I ALL F QQ=0:0 D ASK Q:$D(QFLG) I $D(X),"^"[X Q
QUIT K %,ALL,AOU,AOUCNT,DA,DR,QUE,QFLG,I,ITEM,ITEMNUM,INDT,J,K,QQ,REA1,REA2,RDT,X,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,XMZ,Y,^TMP("PSGWMSG",$J),ZTSK
S:$D(ZTQUEUED) ZTREQ="@" Q
ASK ;
W !!,"Select ITEM: " R X:DTIME S:'$T X="^",QFLG=1 Q:"^"[X W:X?1."?" !!,"Enter the ITEM you wish to inactivate in all AOUs.",! S DIC="^PSDRUG(",DIC(0)="QEOM" D ^DIC K DIC G:Y<0 ASK S ITEM=+Y,REA2=""
W !!,"Select INACTIVATION REASON:",!?5,"(N) - NOT USED",!?5,"(DF) - DELETED FROM FORMULARY",!?5,"(O) - OTHER"
ASKR1 R ?34,"=> ",REA1:DTIME S:'$T REA1="^",QFLG=1 Q:"^"[REA1 G:REA1="O" ASKR2 I REA1'="N",REA1'="DF" W *7,!?37,"Enter 'N', 'DF', or 'O'",! G ASKR1
G QUE
ASKR2 R !!,"Enter INACTIVATION REASON (OTHER): ",REA2:DTIME S:'$T REA2="^",QFLG=1 Q:REA2="^" I REA2]"",REA2?1."?"!($L(REA2)>40!($L(REA2)<3)) W *7,!?5,"ANSWER MUST BE 3-40 CHARACTERS IN LENGTH" G ASKR2
QUE F QQ=0:0 W !!,"Do you want to queue this job" S %=1 D YN^DICN Q:% W !!,"To queue this job to run at a later time and free up your terminal now, accept",!,"the default, otherwise enter 'N' to run it immediately or '^' to Exit"
Q:%<0 S QUE=$S(%=1:1,1:0) I QUE W !!,"You will be notified by MailMan when the job is completed.",!
I %=1 S ZTIO="",ZTRTN="START^PSGWBGIN",ZTDESC="AR/WS MASS ITEM INACTIVATION",ZTSAVE("ITEM")="",ZTSAVE("REA1")="",ZTSAVE("REA2")="",ZTSAVE("QUE")="" D ^%ZTLOAD,HOME^%ZIS K ZTSK Q
START ;
D NOW^%DTC S INDT=X,AOUCNT=0 F AOU=0:0 S AOU=$O(^PSI(58.1,AOU)) Q:'AOU I $D(^PSI(58.1,AOU,1,"B",ITEM)) S ITEMNUM=$O(^PSI(58.1,AOU,1,"B",ITEM,0)) I $D(^PSI(58.1,AOU,1,ITEMNUM,0)),$P(^(0),"^",3)="" D INACT1 S AOUCNT=AOUCNT+1
I 'QUE W *7,!!,$P(^PSDRUG(ITEM,0),"^")," has been inactivated in ",AOUCNT," AOU(s).",! Q
MAIL ;
K XMY S Y=INDT X ^DD("DD") S RDT=Y S ^TMP("PSGWMSG",$J,1,0)="AR/WS ITEM Inactivation Background job has run to completion.",^TMP("PSGWMSG",$J,2,0)="Run Date: "_RDT
S ^TMP("PSGWMSG",$J,3,0)="",^TMP("PSGWMSG",$J,4,0)="ITEM : "_$P(^PSDRUG(ITEM,0),"^"),^TMP("PSGWMSG",$J,5,0)="Has been inactivated as of "_RDT_" in "_AOUCNT_" AOU(s)."
S XMSUB="AR/WS MASS ITEM INACTIVATION SUMMARY",XMDUZ="INPATIENT PHARMACY AR/WS",XMTEXT="^TMP(""PSGWMSG"",$J,",XMY(DUZ)="" S:'$D(XMY) XMY(.5)="" D ^XMD K XMY G QUIT
INACT1 ; Inactivate an Item for ALL AOUs
K DA S DA(1)=AOU,DA=ITEMNUM,DIE="^PSI(58.1,"_DA(1)_",1,",DR="30///"_INDT_";31///"_REA1_";33///"_$S(REA2=""&($P(^PSI(58.1,DA(1),1,DA,0),"^",9)]""):"@",1:REA2) D ^DIE K DIE Q
INACT2 ; Inactivate an Item for a single AOU
K DA,DIE S ALL=0,DA=+Y,DIE="^PSI(58.1,",DR="[PSGW INACTIVATE ITEM]" D ^DIE K DIE S:$D(Y) QFLG=1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWBGIN 2990 printed Dec 13, 2024@01:38:53 Page 2
PSGWBGIN ;BHAM ISC/CML-AR/WS Item Inactivation ; 06 Aug 93 / 2:19 PM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
+2 WRITE !!,"You may inactivate a Stock Item for a single AOU,",!,"or enter ""^ALL"" to inactivate the Item in ALL AOUs.",!
+3 KILL QFLG
FOR QQ=0:0
if $DATA(QFLG)
QUIT
SET ALL=1
SET DIC="^PSI(58.1,"
SET DIC(0)="QEAM"
DO ^DIC
KILL DIC
if Y<0&(X'="^ALL")
QUIT
if X'="^ALL"
DO INACT2
IF ALL
FOR QQ=0:0
DO ASK
if $DATA(QFLG)
QUIT
IF $DATA(X)
IF "^"[X
QUIT
QUIT KILL %,ALL,AOU,AOUCNT,DA,DR,QUE,QFLG,I,ITEM,ITEMNUM,INDT,J,K,QQ,REA1,REA2,RDT,X,XMDUZ,XMKK,XMLOCK,XMR,XMSUB,XMT,XMTEXT,XMZ,Y,^TMP("PSGWMSG",$JOB),ZTSK
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
ASK ;
+1 WRITE !!,"Select ITEM: "
READ X:DTIME
if '$TEST
SET X="^"
SET QFLG=1
if "^"[X
QUIT
if X?1."?"
WRITE !!,"Enter the ITEM you wish to inactivate in all AOUs.",!
SET DIC="^PSDRUG("
SET DIC(0)="QEOM"
DO ^DIC
KILL DIC
if Y<0
GOTO ASK
SET ITEM=+Y
SET REA2=""
+2 WRITE !!,"Select INACTIVATION REASON:",!?5,"(N) - NOT USED",!?5,"(DF) - DELETED FROM FORMULARY",!?5,"(O) - OTHER"
ASKR1 READ ?34,"=> ",REA1:DTIME
if '$TEST
SET REA1="^"
SET QFLG=1
if "^"[REA1
QUIT
if REA1="O"
GOTO ASKR2
IF REA1'="N"
IF REA1'="DF"
WRITE *7,!?37,"Enter 'N', 'DF', or 'O'",!
GOTO ASKR1
+1 GOTO QUE
ASKR2 READ !!,"Enter INACTIVATION REASON (OTHER): ",REA2:DTIME
if '$TEST
SET REA2="^"
SET QFLG=1
if REA2="^"
QUIT
IF REA2]""
IF REA2?1."?"!($LENGTH(REA2)>40!($LENGTH(REA2)<3))
WRITE *7,!?5,"ANSWER MUST BE 3-40 CHARACTERS IN LENGTH"
GOTO ASKR2
QUE FOR QQ=0:0
WRITE !!,"Do you want to queue this job"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !!,"To queue this job to run at a later time and free up your terminal now, accept",!,"the default, otherwise enter 'N' to run it immediately or '^' to Exit"
+1 if %<0
QUIT
SET QUE=$SELECT(%=1:1,1:0)
IF QUE
WRITE !!,"You will be notified by MailMan when the job is completed.",!
+2 IF %=1
SET ZTIO=""
SET ZTRTN="START^PSGWBGIN"
SET ZTDESC="AR/WS MASS ITEM INACTIVATION"
SET ZTSAVE("ITEM")=""
SET ZTSAVE("REA1")=""
SET ZTSAVE("REA2")=""
SET ZTSAVE("QUE")=""
DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
QUIT
START ;
+1 DO NOW^%DTC
SET INDT=X
SET AOUCNT=0
FOR AOU=0:0
SET AOU=$ORDER(^PSI(58.1,AOU))
if 'AOU
QUIT
IF $DATA(^PSI(58.1,AOU,1,"B",ITEM))
SET ITEMNUM=$ORDER(^PSI(58.1,AOU,1,"B",ITEM,0))
IF $DATA(^PSI(58.1,AOU,1,ITEMNUM,0))
IF $PIECE(^(0),"^",3)=""
DO INACT1
SET AOUCNT=AOUCNT+1
+2 IF 'QUE
WRITE *7,!!,$PIECE(^PSDRUG(ITEM,0),"^")," has been inactivated in ",AOUCNT," AOU(s).",!
QUIT
MAIL ;
+1 KILL XMY
SET Y=INDT
XECUTE ^DD("DD")
SET RDT=Y
SET ^TMP("PSGWMSG",$JOB,1,0)="AR/WS ITEM Inactivation Background job has run to completion."
SET ^TMP("PSGWMSG",$JOB,2,0)="Run Date: "_RDT
+2 SET ^TMP("PSGWMSG",$JOB,3,0)=""
SET ^TMP("PSGWMSG",$JOB,4,0)="ITEM : "_$PIECE(^PSDRUG(ITEM,0),"^")
SET ^TMP("PSGWMSG",$JOB,5,0)="Has been inactivated as of "_RDT_" in "_AOUCNT_" AOU(s)."
+3 SET XMSUB="AR/WS MASS ITEM INACTIVATION SUMMARY"
SET XMDUZ="INPATIENT PHARMACY AR/WS"
SET XMTEXT="^TMP(""PSGWMSG"",$J,"
SET XMY(DUZ)=""
if '$DATA(XMY)
SET XMY(.5)=""
DO ^XMD
KILL XMY
GOTO QUIT
INACT1 ; Inactivate an Item for ALL AOUs
+1 KILL DA
SET DA(1)=AOU
SET DA=ITEMNUM
SET DIE="^PSI(58.1,"_DA(1)_",1,"
SET DR="30///"_INDT_";31///"_REA1_";33///"_$SELECT(REA2=""&($PIECE(^PSI(58.1,DA(1),1,DA,0),"^",9)]""):"@",1:REA2)
DO ^DIE
KILL DIE
QUIT
INACT2 ; Inactivate an Item for a single AOU
+1 KILL DA,DIE
SET ALL=0
SET DA=+Y
SET DIE="^PSI(58.1,"
SET DR="[PSGW INACTIVATE ITEM]"
DO ^DIE
KILL DIE
if $DATA(Y)
SET QFLG=1
QUIT
