PSGWPOST ;BHAM/CML-POST INIT CONVERSION ROUTINE ; 27 Dec 93 / 11:12 AM
;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
START ;
S XQABT4=$H
W !!,"Beginning post-init..." S RRFLG=0 D POST1,POST2,POST3,POST4,^PSGWPST1
FINAL ;Set AR/WS node in file #59.7
I '$D(^PS(59.7,1,0)) S X=$S($D(^DD("SITE"))[0:"UNKNOWN",^("SITE")]"":^("SITE"),1:"UNKNOWN"),$P(^PS(59.7,0),"^",3,4)="1^1",^(1,0)=X,^PS(59.7,"B",X,1)=""
S $P(^PS(59.7,1,59.99),"^")="2.3",$P(^(59.99),"^",2)=INITDT S:RRFLG $P(^(59.99),"^",6)=INITDT
QUIT D NOW^%DTC S (DONE,Y)=% X ^DD("DD") S PRT=Y I $D(START) D TIME
W !!,"Post-init completed ",PRT,".",!,"AR/WS Version 2.3 has been successfully installed!",!!,"Initialization process took ",MIN," minutes."
S XQABT5=$H,X="PSGWINIY" X ^%ZOSF("TEST") I $T D @("^"_X)
K AOU,CNT,INITDT,ITM,REA,RET,RRFLG,DONE,MIN,PRT,START,X1,X2,%,X,Y,XQABT1,XQABT2,XQABT3,XQABT4,XQABT5 Q
TIME S X=START,X1=DONE,Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S X=X*1440+Y,MIN=X Q
POST1 ;Convert RETURN REASON subfield to new location as multiple
I $D(^PS(59.7,1,59.99)),$P(^(59.99),"^",6)]"" W !!,"Post-init conversion of RETURN REASON subfield has already been done!" Q
W !!,"Now moving existing RETURN REASON data to new location"
F AOU=0:0 S AOU=$O(^PSI(58.1,AOU)) Q:'AOU F ITM=0:0 S ITM=$O(^PSI(58.1,AOU,1,ITM)) Q:'ITM F RET=0:0 S RET=$O(^PSI(58.1,AOU,1,ITM,3,RET)) Q:'RET I $D(^PSI(58.1,AOU,1,ITM,3,RET,0)) D MOVE
S RRFLG=1 Q
MOVE ;
S REA=$P(^PSI(58.1,AOU,1,ITM,3,RET,0),"^",3)
I REA]"" S ^PSI(58.1,AOU,1,ITM,3,RET,1,0)="^58.152S^1^1",^PSI(58.1,AOU,1,ITM,3,RET,1,1,0)=REA W "." S $P(^PSI(58.1,AOU,1,ITM,3,RET,0),"^",3)=""
Q
POST2 ;Re-index "IU" cross-reference in the Drug file (#50)
W !!,"Now re-indexing the ""IU"" cross-reference in the Drug file (#50)"
K ^PSDRUG("IU") S CNT=0 F DRG=0:0 S DRG=$O(^PSDRUG(DRG)) Q:'DRG I $D(^PSDRUG(DRG,2)),$P(^(2),"^",3)]"" S ^PSDRUG("IU",$P(^(2),"^",3),DRG)="" S CNT=CNT+1 W:CNT#50=0 "."
K DRG Q
POST3 ;Re-initialize sort keys for AOU Inventory Groups
Q:'$O(^PSI(58.2,0))
W !!,"Now re-initializing sort keys for AOUs in AOU Inventory Group file (#58.2)" D IG^PSGWUTL1
Q
POST4 ;Check for duplicate entries in ITEM subfile (#58.11) of 58.1
W !!,"Now checking for duplicate entries in the ITEM subfile of the Pharmacy",!,"AOU Stock file."
D NOW^%DTC S PSGWDT=X,CNT=0
F AOU=0:0 S AOU=$O(^PSI(58.1,AOU)) Q:'AOU F DRG=0:0 S DRG=$O(^PSI(58.1,AOU,1,"B",DRG)) Q:'DRG S ITM=$O(^PSI(58.1,AOU,1,"B",DRG,0)) I $O(^PSI(58.1,AOU,1,"B",DRG,ITM)) S ACNT=0 D
.S ITMT=ITM,IDT=$P($G(^PSI(58.1,AOU,1,ITMT,0)),"^",3) S:IDT=""!(IDT>PSGWDT) ACNT=1 F S ITMT=$O(^PSI(58.1,AOU,1,"B",DRG,ITMT)) Q:'ITMT D ACHK I ACNT'<2 S CNT=CNT+1
I CNT=0 W !!,"No duplicate entries exist !" G EPST4
W !!,"Duplicate entries exist.",!,"A MailMan message is being sent to you regarding the problem." D
.K XMY S ^TMP("PSGWDUP",$J,1,0)="Duplicate entries exist in the ITEM subfile (#58.11) of the PHARMACY AOU"
.S ^TMP("PSGWDUP",$J,2,0)="STOCK file (#58.1). Please execute the following procedures to clean the",^TMP("PSGWDUP",$J,3,0)="subfile:",(^TMP("PSGWDUP",$J,4,0),^TMP("PSGWDUP",$J,5,0))=""
.S ^TMP("PSGWDUP",$J,6,0)=" 1. Run the option Duplicate Entry Report to obtain a listing of the",^TMP("PSGWDUP",$J,7,0)=" duplicates with their inventory, on-demand, and return data."
.S ^TMP("PSGWDUP",$J,8,0)=""
.S ^TMP("PSGWDUP",$J,9,0)=" 2. With the information provided on the report, choose the duplicate",^TMP("PSGWDUP",$J,10,0)=" that needs to be removed.",^TMP("PSGWDUP",$J,11,0)=""
.S ^TMP("PSGWDUP",$J,12,0)=" 3. Enter a phrase such as ""DO NOT USE"" in the LOCATION field of the",^TMP("PSGWDUP",$J,13,0)=" inactivated item. The option Stock Items - Enter/Edit will allow"
.S ^TMP("PSGWDUP",$J,14,0)=" one to edit the LOCATION field.",(^TMP("PSGWDUP",$J,15,0),^TMP("PSGWDUP",$J,16,0))=""
.S ^TMP("PSGWDUP",$J,17,0)=" 4. Inactivate the chosen item in the option Inactivate AOU Stock Item.",^TMP("PSGWDUP",$J,18,0)=""
.S ^TMP("PSGWDUP",$J,19,0)="The Purge Dispensing Data option will purge the item from the subfile 100 days from the date of the item's last activity."
.S XMSUB="Duplicate entries in ITEM subfile.",XMTEXT="^TMP(""PSGWDUP"",$J," S XMDUZ="INPATIENT PHARMACY AR/WS"
.S XMY(DUZ)="" F PSGWDUZ=0:0 S PSGWDUZ=$O(^XUSEC("PSGWMGR",PSGWDUZ)) Q:'PSGWDUZ S XMY(PSGWDUZ)=""
.D ^XMD K XMY,^TMP("PSGWDUP",$J),XMDUZ,XMTEXT,XMSUB,PSGWDUZ
EPST4 K ACNT,IDT,ITMT,PSGWDT
Q
ACHK ;** continue checking for number of active items
S IDT=$P($G(^PSI(58.1,AOU,1,ITMT,0)),"^",3) S:IDT=""!(IDT>PSGWDT) ACNT=ACNT+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGWPOST 4716 printed Apr 09, 2024@20:45:21 Page 2
PSGWPOST ;BHAM/CML-POST INIT CONVERSION ROUTINE ; 27 Dec 93 / 11:12 AM
+1 ;;2.3; Automatic Replenishment/Ward Stock ;;4 JAN 94
START ;
+1 SET XQABT4=$HOROLOG
+2 WRITE !!,"Beginning post-init..."
SET RRFLG=0
DO POST1
DO POST2
DO POST3
DO POST4
DO ^PSGWPST1
FINAL ;Set AR/WS node in file #59.7
+1 IF '$DATA(^PS(59.7,1,0))
SET X=$SELECT($DATA(^DD("SITE"))[0:"UNKNOWN",^("SITE")]"":^("SITE"),1:"UNKNOWN")
SET $PIECE(^PS(59.7,0),"^",3,4)="1^1"
SET ^(1,0)=X
SET ^PS(59.7,"B",X,1)=""
+2 SET $PIECE(^PS(59.7,1,59.99),"^")="2.3"
SET $PIECE(^(59.99),"^",2)=INITDT
if RRFLG
SET $PIECE(^(59.99),"^",6)=INITDT
QUIT DO NOW^%DTC
SET (DONE,Y)=%
XECUTE ^DD("DD")
SET PRT=Y
IF $DATA(START)
DO TIME
+1 WRITE !!,"Post-init completed ",PRT,".",!,"AR/WS Version 2.3 has been successfully installed!",!!,"Initialization process took ",MIN," minutes."
+2 SET XQABT5=$HOROLOG
SET X="PSGWINIY"
XECUTE ^%ZOSF("TEST")
IF $TEST
DO @("^"_X)
+3 KILL AOU,CNT,INITDT,ITM,REA,RET,RRFLG,DONE,MIN,PRT,START,X1,X2,%,X,Y,XQABT1,XQABT2,XQABT3,XQABT4,XQABT5
QUIT
TIME SET X=START
SET X1=DONE
SET Y=$EXTRACT(X1_"000",9,10)-$EXTRACT(X_"000",9,10)*60+$EXTRACT(X1_"00000",11,12)-$EXTRACT(X_"00000",11,12)
SET X2=X
SET X=$PIECE(X,".",1)'=$PIECE(X1,".",1)
if X
DO ^%DTC
SET X=X*1440+Y
SET MIN=X
QUIT
POST1 ;Convert RETURN REASON subfield to new location as multiple
+1 IF $DATA(^PS(59.7,1,59.99))
IF $PIECE(^(59.99),"^",6)]""
WRITE !!,"Post-init conversion of RETURN REASON subfield has already been done!"
QUIT
+2 WRITE !!,"Now moving existing RETURN REASON data to new location"
+3 FOR AOU=0:0
SET AOU=$ORDER(^PSI(58.1,AOU))
if 'AOU
QUIT
FOR ITM=0:0
SET ITM=$ORDER(^PSI(58.1,AOU,1,ITM))
if 'ITM
QUIT
FOR RET=0:0
SET RET=$ORDER(^PSI(58.1,AOU,1,ITM,3,RET))
if 'RET
QUIT
IF $DATA(^PSI(58.1,AOU,1,ITM,3,RET,0))
DO MOVE
+4 SET RRFLG=1
QUIT
MOVE ;
+1 SET REA=$PIECE(^PSI(58.1,AOU,1,ITM,3,RET,0),"^",3)
+2 IF REA]""
SET ^PSI(58.1,AOU,1,ITM,3,RET,1,0)="^58.152S^1^1"
SET ^PSI(58.1,AOU,1,ITM,3,RET,1,1,0)=REA
WRITE "."
SET $PIECE(^PSI(58.1,AOU,1,ITM,3,RET,0),"^",3)=""
+3 QUIT
POST2 ;Re-index "IU" cross-reference in the Drug file (#50)
+1 WRITE !!,"Now re-indexing the ""IU"" cross-reference in the Drug file (#50)"
+2 KILL ^PSDRUG("IU")
SET CNT=0
FOR DRG=0:0
SET DRG=$ORDER(^PSDRUG(DRG))
if 'DRG
QUIT
IF $DATA(^PSDRUG(DRG,2))
IF $PIECE(^(2),"^",3)]""
SET ^PSDRUG("IU",$PIECE(^(2),"^",3),DRG)=""
SET CNT=CNT+1
if CNT#50=0
WRITE "."
+3 KILL DRG
QUIT
POST3 ;Re-initialize sort keys for AOU Inventory Groups
+1 if '$ORDER(^PSI(58.2,0))
QUIT
+2 WRITE !!,"Now re-initializing sort keys for AOUs in AOU Inventory Group file (#58.2)"
DO IG^PSGWUTL1
+3 QUIT
POST4 ;Check for duplicate entries in ITEM subfile (#58.11) of 58.1
+1 WRITE !!,"Now checking for duplicate entries in the ITEM subfile of the Pharmacy",!,"AOU Stock file."
+2 DO NOW^%DTC
SET PSGWDT=X
SET CNT=0
+3 FOR AOU=0:0
SET AOU=$ORDER(^PSI(58.1,AOU))
if 'AOU
QUIT
FOR DRG=0:0
SET DRG=$ORDER(^PSI(58.1,AOU,1,"B",DRG))
if 'DRG
QUIT
SET ITM=$ORDER(^PSI(58.1,AOU,1,"B",DRG,0))
IF $ORDER(^PSI(58.1,AOU,1,"B",DRG,ITM))
SET ACNT=0
Begin DoDot:1
+4 SET ITMT=ITM
SET IDT=$PIECE($GET(^PSI(58.1,AOU,1,ITMT,0)),"^",3)
if IDT=""!(IDT>PSGWDT)
SET ACNT=1
FOR
SET ITMT=$ORDER(^PSI(58.1,AOU,1,"B",DRG,ITMT))
if 'ITMT
QUIT
DO ACHK
IF ACNT'<2
SET CNT=CNT+1
End DoDot:1
+5 IF CNT=0
WRITE !!,"No duplicate entries exist !"
GOTO EPST4
+6 WRITE !!,"Duplicate entries exist.",!,"A MailMan message is being sent to you regarding the problem."
Begin DoDot:1
+7 KILL XMY
SET ^TMP("PSGWDUP",$JOB,1,0)="Duplicate entries exist in the ITEM subfile (#58.11) of the PHARMACY AOU"
+8 SET ^TMP("PSGWDUP",$JOB,2,0)="STOCK file (#58.1). Please execute the following procedures to clean the"
SET ^TMP("PSGWDUP",$JOB,3,0)="subfile:"
SET (^TMP("PSGWDUP",$JOB,4,0),^TMP("PSGWDUP",$JOB,5,0))=""
+9 SET ^TMP("PSGWDUP",$JOB,6,0)=" 1. Run the option Duplicate Entry Report to obtain a listing of the"
SET ^TMP("PSGWDUP",$JOB,7,0)=" duplicates with their inventory, on-demand, and return data."
+10 SET ^TMP("PSGWDUP",$JOB,8,0)=""
+11 SET ^TMP("PSGWDUP",$JOB,9,0)=" 2. With the information provided on the report, choose the duplicate"
SET ^TMP("PSGWDUP",$JOB,10,0)=" that needs to be removed."
SET ^TMP("PSGWDUP",$JOB,11,0)=""
+12 SET ^TMP("PSGWDUP",$JOB,12,0)=" 3. Enter a phrase such as ""DO NOT USE"" in the LOCATION field of the"
SET ^TMP("PSGWDUP",$JOB,13,0)=" inactivated item. The option Stock Items - Enter/Edit will allow"
+13 SET ^TMP("PSGWDUP",$JOB,14,0)=" one to edit the LOCATION field."
SET (^TMP("PSGWDUP",$JOB,15,0),^TMP("PSGWDUP",$JOB,16,0))=""
+14 SET ^TMP("PSGWDUP",$JOB,17,0)=" 4. Inactivate the chosen item in the option Inactivate AOU Stock Item."
SET ^TMP("PSGWDUP",$JOB,18,0)=""
+15 SET ^TMP("PSGWDUP",$JOB,19,0)="The Purge Dispensing Data option will purge the item from the subfile 100 days from the date of the item's last activity."
+16 SET XMSUB="Duplicate entries in ITEM subfile."
SET XMTEXT="^TMP(""PSGWDUP"",$J,"
SET XMDUZ="INPATIENT PHARMACY AR/WS"
+17 SET XMY(DUZ)=""
FOR PSGWDUZ=0:0
SET PSGWDUZ=$ORDER(^XUSEC("PSGWMGR",PSGWDUZ))
if 'PSGWDUZ
QUIT
SET XMY(PSGWDUZ)=""
+18 DO ^XMD
KILL XMY,^TMP("PSGWDUP",$JOB),XMDUZ,XMTEXT,XMSUB,PSGWDUZ
End DoDot:1
EPST4 KILL ACNT,IDT,ITMT,PSGWDT
+1 QUIT
ACHK ;** continue checking for number of active items
+1 SET IDT=$PIECE($GET(^PSI(58.1,AOU,1,ITMT,0)),"^",3)
if IDT=""!(IDT>PSGWDT)
SET ACNT=ACNT+1
+2 QUIT
