PSDWCHG ;BIR/JPW-CS Mass Ward (for Drug) Transfer ; 6 July 94
;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
S PSDUZ=DUZ
W !!,"This routine will allow you to do a mass conversion of all drugs in an ",!,"active NAOU from an old Ward designation to a new Ward designation."
W !!,"You may convert a single NAOU, several NAOUs, or enter ^ALL to convert",!,"all NAOUs.",!!
NAOU ;ask NAOU
K DA,DIC
F S DIC=58.8,DIC("A")="Select NAOU: ",DIC(0)="QEA",DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",$P(^(0),""^"",3)=+PSDSITE" D ^DIC K DIC Q:Y<0 S NAOU(+Y)=""
I '$D(NAOU)&(X'="^ALL") G END
I X="^ALL" F PSD=0:0 S PSD=$O(^PSD(58.8,PSD)) Q:'PSD I $S('$D(^PSD(58.8,PSD,"I")):1,'^("I"):1,^("I")>DT:1,1:0),$P($G(^(0)),"^",2)="N",$P($G(^(0)),"^",3)=+PSDSITE S NAOU(PSD)=""
G:'$D(NAOU) END
OLD ;asking for old (current) WARD (FOR DRUG)
K DA,DIR,DIRUT S DIR(0)="PO^42:EM",DIR("A")="Select OLD WARD",DIR("?")="Enter the Ward that currently exists in the WARD (FOR DRUG) field." D ^DIR K DIR I (Y<0)!$D(DIRUT) G END
S OLD=+Y,OLDN=$P(Y,"^",2)
NEW ;asking new (replacement) WARD (FOR DRUG)
K DA,DIR,DIRUT S DIR(0)="PO^42:EM",DIR("A")="Select NEW WARD",DIR("?")="Enter the new Ward you wish to replace "_OLDN D ^DIR K DIR I $D(DIRUT)!(Y<0) W !,"No Action Taken",! G END
S NEW=+Y,NEWN=$P(Y,"^",2)
QUE ;asks queueing information
S QUE=0 W !! K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to queue this job",DIR("?",1)="To queue this job to run at a later time and free up your terminal now,"
S DIR("?")="accept the default, enter 'N' to run immediately or '^' to quit." D ^DIR K DIR I $D(DIRUT) W $C(7),!!,"The WARD change you selected will not be updated.",!! G END
I 'Y W !!,"Converting WARD (for Drug) now..." G START
S QUE=1 W !!,"You will be notified by MailMan when the job is completed.",!!
S ZTIO="",ZTRTN="START^PSDWCHG",ZTDESC="CS MASS WARD CONVERSION" S (ZTSAVE("OLD"),ZTSAVE("OLDN"),ZTSAVE("NEW"),ZTSAVE("NEWN"),ZTSAVE("QUE"),ZTSAVE("PSDUZ"))="" S:$D(NAOU) ZTSAVE("NAOU(")="" D ^%ZTLOAD K ZTSK G END
START ;loop to update ward conversion
K ^TMP("PSDWCHG",$J) S (CNTN,CNTD)=0
F PSDRG=0:0 S PSDRG=$O(^PSD(58.8,"D",PSDRG)) Q:'PSDRG F LOC=0:0 S LOC=$O(^PSD(58.8,"D",PSDRG,OLD,LOC)) Q:'LOC I $D(NAOU(LOC)),$P($G(^PSD(58.8,LOC,0)),"^",2)'="P",$D(^PSD(58.8,LOC,1,PSDRG,0)) S ^TMP("PSDWCHG",$J,LOC,PSDRG)=""
I $D(^TMP("PSDWCHG",$J)) F LOC=0:0 S LOC=$O(^TMP("PSDWCHG",$J,LOC)) Q:'LOC S CNTN=CNTN+1 F PSDRG=0:0 S PSDRG=$O(^TMP("PSDWCHG",$J,LOC,PSDRG)) Q:'PSDRG S CNTD=CNTD+1 D CHG
K ^TMP("PSDWCHG",$J) D:QUE MSG
I 'QUE W $C(7),!!,"Total Stock Drugs converted: ",CNTD,!,"Total NAOU(s) converted: ",CNTN,!
END K %,%H,%I,CNTD,CNTN,DA,DIC,DIE,DIR,DIR,DIRUT,DR,DTOUT,DUOUT,JJ,LOC,NAOU,NEW,NEWN,OLD,OLDN
K PSD,PSDA,PSDOUT,PSDR,PSDRG,PSDUZ,QUE,RDT,SUB,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDWCHG",$J)
S:$D(ZTQUEUED) ZTREQ="@"
Q
CHG ;change wards
K DA,DIK S DA(2)=LOC,DA(1)=PSDRG,DA=OLD,DIK="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",1," D ^DIK K DIK
I '$D(^PSD(58.8,LOC,1,PSDRG,1,NEW,0)) K DA S DA(2)=LOC,DA(1)=PSDRG,DA=NEW,DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",1,",DR=".01////"_NEW D ^DIE K DIE W:'QUE "."
S SUB=0 F JJ=0:0 S JJ=$O(^PSD(58.8,LOC,1,PSDRG,1,JJ)) Q:'JJ S SUB=SUB+1
S $P(^PSD(58.8,LOC,1,PSDRG,1,0),"^",3,4)=NEW_"^"_SUB
Q
MSG ;send mailman message with completed info
K XMY,^TMP("PSDWCMSG",$J) D NOW^%DTC S Y=X X ^DD("DD") S RDT=Y S ^TMP("PSDWCMSG",$J,1,0)="CS PHARM Conversion background job has run to completion.",^TMP("PSDWCMSG",$J,2,0)="Run Date: "_RDT,^TMP("PSDWCMSG",$J,3,0)=""
S ^TMP("PSDWCMSG",$J,4,0)="Old Ward: "_OLDN_" converted to New Ward: "_NEWN,^TMP("PSDWCMSG",$J,5,0)="Total number of NAOU(s) converted: "_CNTN
S ^TMP("PSDWCMSG",$J,6,0)="Total number of Stock Drugs converted: "_CNTD
S XMSUB="CS PHARM MASS WARD CONVERSION SUMMARY",XMTEXT="^TMP(""PSDWCMSG"",$J,",XMDUZ="CONTROLLED SUBSTANCES PHARMACY",XMY(PSDUZ)="" S:'$D(XMY) XMY(.5)="" D ^XMD K XMY,^TMP("PSDWCMSG",$J)
Q
PSDWCHG ;BIR/JPW-CS Mass Ward (for Drug) Transfer ; 6 July 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;;13 Feb 97
+2 IF '$DATA(PSDSITE)
DO ^PSDSET
IF '$DATA(PSDSITE)
QUIT
+3 SET PSDUZ=DUZ
+4 WRITE !!,"This routine will allow you to do a mass conversion of all drugs in an ",!,"active NAOU from an old Ward designation to a new Ward designation."
+5 WRITE !!,"You may convert a single NAOU, several NAOUs, or enter ^ALL to convert",!,"all NAOUs.",!!
NAOU ;ask NAOU
+1 KILL DA,DIC
+2 FOR
SET DIC=58.8
SET DIC("A")="Select NAOU: "
SET DIC(0)="QEA"
SET DIC("S")="I $S('$D(^(""I"")):1,'^(""I""):1,^(""I"")>DT:1,1:0),$P(^(0),""^"",2)=""N"",$P(^(0),""^"",3)=+PSDSITE"
DO ^DIC
KILL DIC
IF Y<0
QUIT
SET NAOU(+Y)=""
+3 IF '$DATA(NAOU)&(X'="^ALL")
GOTO END
+4 IF X="^ALL"
FOR PSD=0:0
SET PSD=$ORDER(^PSD(58.8,PSD))
IF 'PSD
QUIT
IF $SELECT('$DATA(^PSD(58.8,PSD,"I")):1,'^("I"):1,^("I")>DT:1,1:0)
IF $PIECE($GET(^(0)),"^",2)="N"
IF $PIECE($GET(^(0)),"^",3)=+PSDSITE
SET NAOU(PSD)=""
+5 IF '$DATA(NAOU)
GOTO END
OLD ;asking for old (current) WARD (FOR DRUG)
+1 KILL DA,DIR,DIRUT
SET DIR(0)="PO^42:EM"
SET DIR("A")="Select OLD WARD"
SET DIR("?")="Enter the Ward that currently exists in the WARD (FOR DRUG) field."
DO ^DIR
KILL DIR
IF (Y<0)!$DATA(DIRUT)
GOTO END
+2 SET OLD=+Y
SET OLDN=$PIECE(Y,"^",2)
NEW ;asking new (replacement) WARD (FOR DRUG)
+1 KILL DA,DIR,DIRUT
SET DIR(0)="PO^42:EM"
SET DIR("A")="Select NEW WARD"
SET DIR("?")="Enter the new Ward you wish to replace "_OLDN
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y<0)
WRITE !,"No Action Taken",!
GOTO END
+2 SET NEW=+Y
SET NEWN=$PIECE(Y,"^",2)
QUE ;asks queueing information
+1 SET QUE=0
WRITE !!
KILL DA,DIR,DIRUT
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you want to queue this job"
SET DIR("?",1)="To queue this job to run at a later time and free up your terminal now,"
+2 SET DIR("?")="accept the default, enter 'N' to run immediately or '^' to quit."
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
WRITE $CHAR(7),!!,"The WARD change you selected will not be updated.",!!
GOTO END
+3 IF 'Y
WRITE !!,"Converting WARD (for Drug) now..."
GOTO START
+4 SET QUE=1
WRITE !!,"You will be notified by MailMan when the job is completed.",!!
+5 SET ZTIO=""
SET ZTRTN="START^PSDWCHG"
SET ZTDESC="CS MASS WARD CONVERSION"
SET (ZTSAVE("OLD"),ZTSAVE("OLDN"),ZTSAVE("NEW"),ZTSAVE("NEWN"),ZTSAVE("QUE"),ZTSAVE("PSDUZ"))=""
IF $DATA(NAOU)
SET ZTSAVE("NAOU(")=""
DO ^%ZTLOAD
KILL ZTSK
GOTO END
START ;loop to update ward conversion
+1 KILL ^TMP("PSDWCHG",$JOB)
SET (CNTN,CNTD)=0
+2 FOR PSDRG=0:0
SET PSDRG=$ORDER(^PSD(58.8,"D",PSDRG))
IF 'PSDRG
QUIT
FOR LOC=0:0
SET LOC=$ORDER(^PSD(58.8,"D",PSDRG,OLD,LOC))
IF 'LOC
QUIT
IF $DATA(NAOU(LOC))
IF $PIECE($GET(^PSD(58.8,LOC,0)),"^",2)'="P"
IF $DATA(^PSD(58.8,LOC,1,PSDRG,0))
SET ^TMP("PSDWCHG",$JOB,LOC,PSDRG)=""
+3 IF $DATA(^TMP("PSDWCHG",$JOB))
FOR LOC=0:0
SET LOC=$ORDER(^TMP("PSDWCHG",$JOB,LOC))
IF 'LOC
QUIT
SET CNTN=CNTN+1
FOR PSDRG=0:0
SET PSDRG=$ORDER(^TMP("PSDWCHG",$JOB,LOC,PSDRG))
IF 'PSDRG
QUIT
SET CNTD=CNTD+1
DO CHG
+4 KILL ^TMP("PSDWCHG",$JOB)
IF QUE
DO MSG
+5 IF 'QUE
WRITE $CHAR(7),!!,"Total Stock Drugs converted: ",CNTD,!,"Total NAOU(s) converted: ",CNTN,!
END KILL %,%H,%I,CNTD,CNTN,DA,DIC,DIE,DIR,DIR,DIRUT,DR,DTOUT,DUOUT,JJ,LOC,NAOU,NEW,NEWN,OLD,OLDN
+1 KILL PSD,PSDA,PSDOUT,PSDR,PSDRG,PSDUZ,QUE,RDT,SUB,X,XMDUZ,XMSUB,XMTEXT,XMY,Y,ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,^TMP("PSDWCHG",$JOB)
+2 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+3 QUIT
CHG ;change wards
+1 KILL DA,DIK
SET DA(2)=LOC
SET DA(1)=PSDRG
SET DA=OLD
SET DIK="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",1,"
DO ^DIK
KILL DIK
+2 IF '$DATA(^PSD(58.8,LOC,1,PSDRG,1,NEW,0))
KILL DA
SET DA(2)=LOC
SET DA(1)=PSDRG
SET DA=NEW
SET DIE="^PSD(58.8,"_DA(2)_",1,"_DA(1)_",1,"
SET DR=".01////"_NEW
DO ^DIE
KILL DIE
IF 'QUE
WRITE "."
+3 SET SUB=0
FOR JJ=0:0
SET JJ=$ORDER(^PSD(58.8,LOC,1,PSDRG,1,JJ))
IF 'JJ
QUIT
SET SUB=SUB+1
+4 SET $PIECE(^PSD(58.8,LOC,1,PSDRG,1,0),"^",3,4)=NEW_"^"_SUB
+5 QUIT
MSG ;send mailman message with completed info
+1 KILL XMY,^TMP("PSDWCMSG",$JOB)
DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET RDT=Y
SET ^TMP("PSDWCMSG",$JOB,1,0)="CS PHARM Conversion background job has run to completion."
SET ^TMP("PSDWCMSG",$JOB,2,0)="Run Date: "_RDT
SET ^TMP("PSDWCMSG",$JOB,3,0)=""
+2 SET ^TMP("PSDWCMSG",$JOB,4,0)="Old Ward: "_OLDN_" converted to New Ward: "_NEWN
SET ^TMP("PSDWCMSG",$JOB,5,0)="Total number of NAOU(s) converted: "_CNTN
+3 SET ^TMP("PSDWCMSG",$JOB,6,0)="Total number of Stock Drugs converted: "_CNTD
+4 SET XMSUB="CS PHARM MASS WARD CONVERSION SUMMARY"
SET XMTEXT="^TMP(""PSDWCMSG"",$J,"
SET XMDUZ="CONTROLLED SUBSTANCES PHARMACY"
SET XMY(PSDUZ)=""
IF '$DATA(XMY)
SET XMY(.5)=""
DO ^XMD
KILL XMY,^TMP("PSDWCMSG",$JOB)
+5 QUIT
