PSS1P178 ;BP/CMF - PATCH PSS*1*178 Pre/Post-Init Rtn ;04/20/2010
;;1.0;PHARMACY DATA MANAGEMENT;**178**;9/30/97;Build 14
;
ENV ;environment check
S XPDABORT=""
;D PRODCHK(.XPDABORT) I XPDABORT=2 Q ;comment this line out after sprint 3
D PROGCHK(.XPDABORT) ;checks programmer variables
I XPDABORT="" K XPDABORT
Q
;
PRODCHK(XPDABORT) ;checks for test/production account
I $$PROD^XUPROD DO
. D BMES^XPDUTL("******")
. D MES^XPDUTL("PSS*1*178 is not yet ready for production accounts.")
. D MES^XPDUTL("Installation aborted.")
. D MES^XPDUTL("******")
. S XPDABORT=2
Q
;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
I '$G(DUZ)!($G(DUZ(0))'="@")!('$G(DT))!($G(U)'="^") DO
. D BMES^XPDUTL("******")
. D MES^XPDUTL("Your programming variables are not set up properly.")
. D MES^XPDUTL("Installation aborted.")
. D MES^XPDUTL("******")
. S XPDABORT=2
Q
;
PRE ;; hook for pre install actions
Q
;
POST ;; hook for post install actions
;
;
D BMES^XPDUTL("Now running Dose Unit and Dose Unit Conversion File updates...")
;
MAIN ; Update entries in DOSE UNITS file (51.24)
K XFAIL
F CT=1:1:8 Q:'$G(CT) D @CT D BMES^XPDUTL("Update "_CT_" of 8 "_$S($G(XFAIL)=1:"FAILED",1:"PASSED")) K XFAIL
K DIE,DR,DA,XFAIL,CT,XUMF
D BMES^XPDUTL("-- UPDATE COMPLETE --")
Q
1 ;Verify FDB DOSE Unit = APPLICATORFUL(S) Change as needed (2.6.23.2)
;
;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"
;
K DIE,DR,DA
S DA=2,XUMF=1
S DIE="^PS(51.24,",DR="1////"_"APPLICATORFUL(S)"
D ^DIE
I $P($G(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL(S)" S XFAIL=1 Q
Q
;
2 ;Verify Synonym = APPLICATORFUL/S - Correct if needed Return Synonyms to correct state
;
;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"
;
K DIE,DR,DA
S DA=6,DA(1)=2,XUMF=1
S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"
D ^DIE
I $G(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S" S XFAIL=1 Q
Q
;
3 ;Verify FDB DOSE Unit = SUPPOSITORY(IES) Change as needed (2.6.23.3)
;
;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"
;
K DIE,DR,DA
S DA=40,XUMF=1
S DIE="^PS(51.24,",DR="1////"_"SUPPOSITORY(IES)"
D ^DIE
I $P($G(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY(IES)" S XFAIL=1 Q
Q
;
4 ;Verify Synonym = SUPPOSITORY/IES and correct if needed
;
;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"
;
K DIE,DR,DA
S DA=4,DA(1)=40,XUMF=1
S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"
D ^DIE
I $G(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES" S XFAIL=1 Q
Q
;
5 ;CHANGE APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.10)
;
;^PS(51.25,3,0)="APPLICATORFUL/S"
;
K DIE,DR,DA
S DA=3,XUMF=1
S DIE="^PS(51.25,",DR=".01////"_"APPLICATORFUL(S)"
D ^DIE
I $G(^PS(51.25,3,0))'="APPLICATORFUL(S)" S XFAIL=1 Q
Q
;
6 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.9)
;
;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"
;
K DIE,DR,DA
S DA=18,DA(1)=9,XUMF=1
S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"SUPPOSITORY(IES)"
D ^DIE
I $P($G(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY(IES)" S XFAIL=1 Q
Q
;
7 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.7)
;
;^PS(51.25,55,0)="SUPPOSITORY/IES"
;
K DIE,DR,DA
S DA=55,XUMF=1
S DIE="^PS(51.25,",DR=".01////"_"SUPPOSITORY(IES)"
D ^DIE
I ($G(^PS(51.25,55,0)))'="SUPPOSITORY(IES)" S XFAIL=1 Q
Q
;
8 ;APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.8)
;
;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"
;
K DIE,DR,DA
S DA=1,DA(1)=67,XUMF=1
S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"APPLICATORFUL(S)"
D ^DIE
I $P($G(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL(S)" S XFAIL=1 Q
Q
;
;
RESET ;
;
W !,"RESET 51.24!"
;
R1 ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"
;
K DIE,DR,DA
S DA=2,XUMF=1
S DIE="^PS(51.24,",DR="1////"_"APPLICATORFUL"
D ^DIE
I $P($G(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL" W !,"R1 FAILED!!",! G R2
W !,"R1 PASSED!!"
;
R2 ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"
;
K DIE,DR,DA
S DA=6,DA(1)=2,XUMF=1
S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"
D ^DIE
I $G(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S" W !,"R2 FAILED!!" G R3
W !,"R2 PASSED!!"
;
R3 ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"
;
K DIE,DR,DA
S DA=40,XUMF=1
S DIE="^PS(51.24,",DR="1////"_"SUPPOSITORY"
D ^DIE
I $P($G(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY" W !,"R3 FAILED!!" G R4
W !,"R3 PASSED!!"
;
R4 ;
;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"
;Reset SUPPOSITORY(IES) TO SUPPOSITORY/IES for testing
N DIE,DR,DA
S DA=4,DA(1)=40,XUMF=1
S DIE="^PS(51.24,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"
D ^DIE
I $G(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES" W !,"R4 Failed!" G R5
W !,"R4 PASSED!!"
;
W !!,"RESET 51.25!"
;
R5 ;
;^PS(51.25,3,0)="APPLICATORFUL/S"
;RESET APPLICATORFUL(S) to APPLICATORFUL/S for testing
;
K DIE,DR,DA
S DA=3,XUMF=1
S DIE="^PS(51.25,",DR=".01////"_"APPLICATORFUL/S"
D ^DIE
I $G(^PS(51.25,3,0))'="APPLICATORFUL/S" W !,"R5 Failed!" G R6
W !,"R5 PASSED!!"
;
R6 ;
;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"
;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES
;
N DIE,DR,DA
S DA=18,DA(1)=9,XUMF=1
S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"SUPPOSITORY/IES"
D ^DIE
I $P($G(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY/IES" W !,"R6 Failed!" G R7
W !,"R6 PASSED!!"
;
R7 ;
;^PS(51.25,55,0)="SUPPOSITORY/IES"
;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES
;
;^PS(51.25,55,0)="SUPPOSITORY/IES"
;
K DIE,DR,DA
S DA=55,XUMF=1
S DIE="^PS(51.25,",DR=".01////"_"SUPPOSITORY/IES"
D ^DIE
I ($G(^PS(51.25,55,0)))'="SUPPOSITORY/IES" W !,"R7 Failed!" G R8
W !,"R7 PASSED!!"
;
R8 ;
;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"
;RESET APPLICATORFUL(S) to APPLICATORFUL/S
;
N DIE,DR,DA
S DA=1,DA(1)=67,XUMF=1
S DIE="^PS(51.25,DA(1),1,",DR=".01////"_"APPLICATORFUL/S"
D ^DIE
I $P($G(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL/S" W !,"R8 Failed!" Q
W !,"R8 PASSED!!",!!!
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSS1P178 5956 printed Apr 09, 2024@21:33:14 Page 2
PSS1P178 ;BP/CMF - PATCH PSS*1*178 Pre/Post-Init Rtn ;04/20/2010
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**178**;9/30/97;Build 14
+2 ;
ENV ;environment check
+1 SET XPDABORT=""
+2 ;D PRODCHK(.XPDABORT) I XPDABORT=2 Q ;comment this line out after sprint 3
+3 ;checks programmer variables
DO PROGCHK(.XPDABORT)
+4 IF XPDABORT=""
KILL XPDABORT
+5 QUIT
+6 ;
PRODCHK(XPDABORT) ;checks for test/production account
+1 IF $$PROD^XUPROD
Begin DoDot:1
+2 DO BMES^XPDUTL("******")
+3 DO MES^XPDUTL("PSS*1*178 is not yet ready for production accounts.")
+4 DO MES^XPDUTL("Installation aborted.")
+5 DO MES^XPDUTL("******")
+6 SET XPDABORT=2
End DoDot:1
+7 QUIT
+8 ;
PROGCHK(XPDABORT) ;checks for necessary programmer variables
+1 IF '$GET(DUZ)!($GET(DUZ(0))'="@")!('$GET(DT))!($GET(U)'="^")
Begin DoDot:1
+2 DO BMES^XPDUTL("******")
+3 DO MES^XPDUTL("Your programming variables are not set up properly.")
+4 DO MES^XPDUTL("Installation aborted.")
+5 DO MES^XPDUTL("******")
+6 SET XPDABORT=2
End DoDot:1
+7 QUIT
+8 ;
PRE ;; hook for pre install actions
+1 QUIT
+2 ;
POST ;; hook for post install actions
+1 ;
+2 ;
+3 DO BMES^XPDUTL("Now running Dose Unit and Dose Unit Conversion File updates...")
+4 ;
MAIN ; Update entries in DOSE UNITS file (51.24)
+1 KILL XFAIL
+2 FOR CT=1:1:8
if '$GET(CT)
QUIT
DO @CT
DO BMES^XPDUTL("Update "_CT_" of 8 "_$SELECT($GET(XFAIL)=1:"FAILED",1:"PASSED"))
KILL XFAIL
+3 KILL DIE,DR,DA,XFAIL,CT,XUMF
+4 DO BMES^XPDUTL("-- UPDATE COMPLETE --")
+5 QUIT
1 ;Verify FDB DOSE Unit = APPLICATORFUL(S) Change as needed (2.6.23.2)
+1 ;
+2 ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=2
SET XUMF=1
+6 SET DIE="^PS(51.24,"
SET DR="1////"_"APPLICATORFUL(S)"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL(S)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
2 ;Verify Synonym = APPLICATORFUL/S - Correct if needed Return Synonyms to correct state
+1 ;
+2 ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=6
SET DA(1)=2
SET XUMF=1
+6 SET DIE="^PS(51.24,DA(1),1,"
SET DR=".01////"_"APPLICATORFUL/S"
+7 DO ^DIE
+8 IF $GET(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
3 ;Verify FDB DOSE Unit = SUPPOSITORY(IES) Change as needed (2.6.23.3)
+1 ;
+2 ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=40
SET XUMF=1
+6 SET DIE="^PS(51.24,"
SET DR="1////"_"SUPPOSITORY(IES)"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY(IES)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
4 ;Verify Synonym = SUPPOSITORY/IES and correct if needed
+1 ;
+2 ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=4
SET DA(1)=40
SET XUMF=1
+6 SET DIE="^PS(51.24,DA(1),1,"
SET DR=".01////"_"SUPPOSITORY/IES"
+7 DO ^DIE
+8 IF $GET(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
5 ;CHANGE APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.10)
+1 ;
+2 ;^PS(51.25,3,0)="APPLICATORFUL/S"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=3
SET XUMF=1
+6 SET DIE="^PS(51.25,"
SET DR=".01////"_"APPLICATORFUL(S)"
+7 DO ^DIE
+8 IF $GET(^PS(51.25,3,0))'="APPLICATORFUL(S)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
6 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.9)
+1 ;
+2 ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=18
SET DA(1)=9
SET XUMF=1
+6 SET DIE="^PS(51.25,DA(1),1,"
SET DR=".01////"_"SUPPOSITORY(IES)"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY(IES)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
7 ;CHANGE SUPPOSITORY/IES to SUPPOSITORY(IES) (2.6.21.7)
+1 ;
+2 ;^PS(51.25,55,0)="SUPPOSITORY/IES"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=55
SET XUMF=1
+6 SET DIE="^PS(51.25,"
SET DR=".01////"_"SUPPOSITORY(IES)"
+7 DO ^DIE
+8 IF ($GET(^PS(51.25,55,0)))'="SUPPOSITORY(IES)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
8 ;APPLICATORFUL/S to APPLICATORFUL(S) (2.6.21.8)
+1 ;
+2 ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=1
SET DA(1)=67
SET XUMF=1
+6 SET DIE="^PS(51.25,DA(1),1,"
SET DR=".01////"_"APPLICATORFUL(S)"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL(S)"
SET XFAIL=1
QUIT
+9 QUIT
+10 ;
+11 ;
RESET ;
+1 ;
+2 WRITE !,"RESET 51.24!"
+3 ;
R1 ;^PS(51.24,2,0)="APPLICATORFUL(S)^APPLICATORFUL^1"
+1 ;
+2 KILL DIE,DR,DA
+3 SET DA=2
SET XUMF=1
+4 SET DIE="^PS(51.24,"
SET DR="1////"_"APPLICATORFUL"
+5 DO ^DIE
+6 IF $PIECE($GET(^PS(51.24,2,0)),"^",2)'="APPLICATORFUL"
WRITE !,"R1 FAILED!!",!
GOTO R2
+7 WRITE !,"R1 PASSED!!"
+8 ;
R2 ;^PS(51.24,2,1,6,0)="APPLICATORFUL/S"
+1 ;
+2 KILL DIE,DR,DA
+3 SET DA=6
SET DA(1)=2
SET XUMF=1
+4 SET DIE="^PS(51.24,DA(1),1,"
SET DR=".01////"_"APPLICATORFUL/S"
+5 DO ^DIE
+6 IF $GET(^PS(51.24,2,1,6,0))'="APPLICATORFUL/S"
WRITE !,"R2 FAILED!!"
GOTO R3
+7 WRITE !,"R2 PASSED!!"
+8 ;
R3 ;^PS(51.24,40,0)="SUPPOSITORY(IES)^SUPPOSITORY^1"
+1 ;
+2 KILL DIE,DR,DA
+3 SET DA=40
SET XUMF=1
+4 SET DIE="^PS(51.24,"
SET DR="1////"_"SUPPOSITORY"
+5 DO ^DIE
+6 IF $PIECE($GET(^PS(51.24,40,0)),"^",2)'="SUPPOSITORY"
WRITE !,"R3 FAILED!!"
GOTO R4
+7 WRITE !,"R3 PASSED!!"
+8 ;
R4 ;
+1 ;^PS(51.24,40,1,4,0)="SUPPOSITORY/IES"
+2 ;Reset SUPPOSITORY(IES) TO SUPPOSITORY/IES for testing
+3 NEW DIE,DR,DA
+4 SET DA=4
SET DA(1)=40
SET XUMF=1
+5 SET DIE="^PS(51.24,DA(1),1,"
SET DR=".01////"_"SUPPOSITORY/IES"
+6 DO ^DIE
+7 IF $GET(^PS(51.24,40,1,4,0))'="SUPPOSITORY/IES"
WRITE !,"R4 Failed!"
GOTO R5
+8 WRITE !,"R4 PASSED!!"
+9 ;
+10 WRITE !!,"RESET 51.25!"
+11 ;
R5 ;
+1 ;^PS(51.25,3,0)="APPLICATORFUL/S"
+2 ;RESET APPLICATORFUL(S) to APPLICATORFUL/S for testing
+3 ;
+4 KILL DIE,DR,DA
+5 SET DA=3
SET XUMF=1
+6 SET DIE="^PS(51.25,"
SET DR=".01////"_"APPLICATORFUL/S"
+7 DO ^DIE
+8 IF $GET(^PS(51.25,3,0))'="APPLICATORFUL/S"
WRITE !,"R5 Failed!"
GOTO R6
+9 WRITE !,"R5 PASSED!!"
+10 ;
R6 ;
+1 ;^PS(51.25,9,1,18,0)="SUPPOSITORY/IES^1"
+2 ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES
+3 ;
+4 NEW DIE,DR,DA
+5 SET DA=18
SET DA(1)=9
SET XUMF=1
+6 SET DIE="^PS(51.25,DA(1),1,"
SET DR=".01////"_"SUPPOSITORY/IES"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.25,9,1,18,0)),U,1)'="SUPPOSITORY/IES"
WRITE !,"R6 Failed!"
GOTO R7
+9 WRITE !,"R6 PASSED!!"
+10 ;
R7 ;
+1 ;^PS(51.25,55,0)="SUPPOSITORY/IES"
+2 ;RESET SUPPOSITORY(IES) to SUPPOSITORY/IES
+3 ;
+4 ;^PS(51.25,55,0)="SUPPOSITORY/IES"
+5 ;
+6 KILL DIE,DR,DA
+7 SET DA=55
SET XUMF=1
+8 SET DIE="^PS(51.25,"
SET DR=".01////"_"SUPPOSITORY/IES"
+9 DO ^DIE
+10 IF ($GET(^PS(51.25,55,0)))'="SUPPOSITORY/IES"
WRITE !,"R7 Failed!"
GOTO R8
+11 WRITE !,"R7 PASSED!!"
+12 ;
R8 ;
+1 ;^PS(51.25,67,1,1,0)="APPLICATORFUL/S^1"
+2 ;RESET APPLICATORFUL(S) to APPLICATORFUL/S
+3 ;
+4 NEW DIE,DR,DA
+5 SET DA=1
SET DA(1)=67
SET XUMF=1
+6 SET DIE="^PS(51.25,DA(1),1,"
SET DR=".01////"_"APPLICATORFUL/S"
+7 DO ^DIE
+8 IF $PIECE($GET(^PS(51.25,67,1,1,0)),U,1)'="APPLICATORFUL/S"
WRITE !,"R8 Failed!"
QUIT
+9 WRITE !,"R8 PASSED!!",!!!
+10 ;
+11 QUIT
