PSB394P ;MNT/BJR - Move Units Given field to Units Ordered ;
;;3.0;BAR CODE MED ADMIN;**94**;APR 2016;Build 4
;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
;
Q
EN ;This routine will move the date in the units given field to the units ordered field for patch PSB*3*94
N DR,DA,DIE,XX,SDT
D MES^XPDUTL("")
D MES^XPDUTL("*** PSB*3*94 Post Install Running ***")
D MES^XPDUTL("")
N X,PSBIEN,PSBADD,PSBDOSE,PSBSTAT,PSBSOL
D NOW^%DTC S ^XTMP("PSB94P",0)=$$FMADD^XLFDT(X,30)_"^"_X_"^"_"PSB*3.0*94 Changed Entries"
S XX=0 F S XX=$O(^PSB(53.79,"AEDT",XX)) Q:XX'>0 S SDT=3160331.5959 F S SDT=$O(^PSB(53.79,"AEDT",XX,SDT)) Q:SDT'>0 S PSBIEN=0 F S PSBIEN=$O(^PSB(53.79,"AEDT",XX,SDT,PSBIEN)) Q:PSBIEN'>0 D
.I $G(^PSB(53.79,PSBIEN,.6,0))'="" S PSBADD=0 F S PSBADD=$O(^PSB(53.79,PSBIEN,.6,PSBADD)) Q:'PSBADD D
..M:'$D(^XTMP("PSB94P",PSBIEN,.6)) ^XTMP("PSB94P",PSBIEN,.6)=^PSB(53.79,PSBIEN,.6) S PSBDOSE=$$GET1^DIQ(53.796,PSBADD_","_PSBIEN,.03),PSBSTAT=$$GET1^DIQ(53.79,PSBIEN,.09,"I")
..I PSBDOSE'="" S DR=".02///^S X=PSBDOSE",DIE="^PSB(53.79,"_PSBIEN_",.6,",DA(1)=PSBIEN,DA=PSBADD D ^DIE K DR,DA,DIE
..I PSBSTAT'="G",PSBSTAT'="RM",PSBSTAT'="I",PSBSTAT'="C" S DR=".03///^S X=""@""",DIE="^PSB(53.79,"_PSBIEN_",.6,",DA(1)=PSBIEN,DA=PSBADD D ^DIE K DR,DA,DIE
.I $G(^PSB(53.79,PSBIEN,.7,0))'="" S PSBSOL=0 F S PSBSOL=$O(^PSB(53.79,PSBIEN,.7,PSBSOL)) Q:'PSBSOL D
..M:'$D(^XTMP("PSB94P",PSBIEN,.7)) ^XTMP("PSB94P",PSBIEN,.7)=^PSB(53.79,PSBIEN,.7) S PSBDOSE=$$GET1^DIQ(53.797,PSBSOL_","_PSBIEN,.03),PSBSTAT=$$GET1^DIQ(53.79,PSBIEN,.09,"I")
..I PSBDOSE'="" S DR=".02///^S X=PSBDOSE",DIE="^PSB(53.79,"_PSBIEN_",.7,",DA(1)=PSBIEN,DA=PSBSOL D ^DIE K DR,DA,DIE
..I PSBSTAT'="G",PSBSTAT'="RM",PSBSTAT'="I",PSBSTAT'="C" S DR=".03///^S X=""@""",DIE="^PSB(53.79,"_PSBIEN_",.7,",DA(1)=PSBIEN,DA=PSBSOL D ^DIE K DR,DA,DIE
D MES^XPDUTL("")
D MES^XPDUTL("*** PSB*3*94 Post Install Complete ***")
D MES^XPDUTL("*** You may review global ^XTMP(""PSB94P"") for a list of entries modified ***")
D MES^XPDUTL("")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSB394P 2092 printed Dec 13, 2024@01:39:45 Page 2
PSB394P ;MNT/BJR - Move Units Given field to Units Ordered ;
+1 ;;3.0;BAR CODE MED ADMIN;**94**;APR 2016;Build 4
+2 ;Per VHA Directive 2004-038 (or future revisions regarding same), this routine should not be modified.
+3 ;
+4 QUIT
EN ;This routine will move the date in the units given field to the units ordered field for patch PSB*3*94
+1 NEW DR,DA,DIE,XX,SDT
+2 DO MES^XPDUTL("")
+3 DO MES^XPDUTL("*** PSB*3*94 Post Install Running ***")
+4 DO MES^XPDUTL("")
+5 NEW X,PSBIEN,PSBADD,PSBDOSE,PSBSTAT,PSBSOL
+6 DO NOW^%DTC
SET ^XTMP("PSB94P",0)=$$FMADD^XLFDT(X,30)_"^"_X_"^"_"PSB*3.0*94 Changed Entries"
+7 SET XX=0
FOR
SET XX=$ORDER(^PSB(53.79,"AEDT",XX))
if XX'>0
QUIT
SET SDT=3160331.5959
FOR
SET SDT=$ORDER(^PSB(53.79,"AEDT",XX,SDT))
if SDT'>0
QUIT
SET PSBIEN=0
FOR
SET PSBIEN=$ORDER(^PSB(53.79,"AEDT",XX,SDT,PSBIEN))
if PSBIEN'>0
QUIT
Begin DoDot:1
+8 IF $GET(^PSB(53.79,PSBIEN,.6,0))'=""
SET PSBADD=0
FOR
SET PSBADD=$ORDER(^PSB(53.79,PSBIEN,.6,PSBADD))
if 'PSBADD
QUIT
Begin DoDot:2
+9 if '$DATA(^XTMP("PSB94P",PSBIEN,.6))
MERGE ^XTMP("PSB94P",PSBIEN,.6)=^PSB(53.79,PSBIEN,.6)
SET PSBDOSE=$$GET1^DIQ(53.796,PSBADD_","_PSBIEN,.03)
SET PSBSTAT=$$GET1^DIQ(53.79,PSBIEN,.09,"I")
+10 IF PSBDOSE'=""
SET DR=".02///^S X=PSBDOSE"
SET DIE="^PSB(53.79,"_PSBIEN_",.6,"
SET DA(1)=PSBIEN
SET DA=PSBADD
DO ^DIE
KILL DR,DA,DIE
+11 IF PSBSTAT'="G"
IF PSBSTAT'="RM"
IF PSBSTAT'="I"
IF PSBSTAT'="C"
SET DR=".03///^S X=""@"""
SET DIE="^PSB(53.79,"_PSBIEN_",.6,"
SET DA(1)=PSBIEN
SET DA=PSBADD
DO ^DIE
KILL DR,DA,DIE
End DoDot:2
+12 IF $GET(^PSB(53.79,PSBIEN,.7,0))'=""
SET PSBSOL=0
FOR
SET PSBSOL=$ORDER(^PSB(53.79,PSBIEN,.7,PSBSOL))
if 'PSBSOL
QUIT
Begin DoDot:2
+13 if '$DATA(^XTMP("PSB94P",PSBIEN,.7))
MERGE ^XTMP("PSB94P",PSBIEN,.7)=^PSB(53.79,PSBIEN,.7)
SET PSBDOSE=$$GET1^DIQ(53.797,PSBSOL_","_PSBIEN,.03)
SET PSBSTAT=$$GET1^DIQ(53.79,PSBIEN,.09,"I")
+14 IF PSBDOSE'=""
SET DR=".02///^S X=PSBDOSE"
SET DIE="^PSB(53.79,"_PSBIEN_",.7,"
SET DA(1)=PSBIEN
SET DA=PSBSOL
DO ^DIE
KILL DR,DA,DIE
+15 IF PSBSTAT'="G"
IF PSBSTAT'="RM"
IF PSBSTAT'="I"
IF PSBSTAT'="C"
SET DR=".03///^S X=""@"""
SET DIE="^PSB(53.79,"_PSBIEN_",.7,"
SET DA(1)=PSBIEN
SET DA=PSBSOL
DO ^DIE
KILL DR,DA,DIE
End DoDot:2
End DoDot:1
+16 DO MES^XPDUTL("")
+17 DO MES^XPDUTL("*** PSB*3*94 Post Install Complete ***")
+18 DO MES^XPDUTL("*** You may review global ^XTMP(""PSB94P"") for a list of entries modified ***")
+19 DO MES^XPDUTL("")
+20 QUIT
