PSJDSS ;ALB/JRC-REGENERATE DSS EXTRACT DATA FILE (#728.113) & (728.904) ; 10/8/08 1:53pm
;;5.0; INPATIENT MEDICATIONS ;**210**;16 DEC 97;Build 27
Q
;
;This routine was written to regenerate lost IV or UD data that is
;normally stored in DSS intermediate files (#728.113) and (#728.904).
;When this routine is invoked the users are prompted for a date range
;The routine then loops thru the "AIV" xref in the case of IV or the
;"AUS" xref in the case of UD, validates the orders and regenerates
;the records.
;
;Important Note: If the entries for a given range are not cleared the
; file is going to end with duplicates, so a check is
; done on file (#728.113) or (#728.904) to see if any
; entries exist, if they do, the program quits.
;
; Input: EXTRACT = "IV" or "UD"
;
EN ;Entry Point
;Check input
Q:'$G(EXTRACT)=""
N STDATE,ENDDATE
;Get start and stop dates
Q:'$$DATE()
Q:'$$CHECK(EXTRACT)
S ZTDESC=EXTRACT_" EXTRACT DATA FILE: "_STDATE_" TO "_ENDDATE_" RECOMPILE",ZTRTN="START^PSJDSS",ZTIO=""
F I="EXTRACT","STDATE","ENDDATE" S ZTSAVE(I)=""
D ^%ZTLOAD
I $D(ZTSK) D
.W !,"Request queued as Task #",ZTSK,".",!
Q
START ;Start recompile after queue
N COUNT
;Process records and update intermediate file
D @EXTRACT
;Send completion message
D MSG
;verify ^tmp global is deleted
K ^TMP($J)
Q
;
DATE() ;Prompt user for start date
N DIR,X,Y,DIRUT
S DIR(0)="D"
S DIR("A")="Enter Start Date"
D ^DIR
I $D(DIRUT) Q 0
S STDATE=Y
;Prompt user for end date
K DIR,X,Y
S DIR(0)="D"
S DIR("A")="Enter Stop Date"
D ^DIR
I $D(DIRUT) Q 0
S ENDDATE=Y
Q 1
;
CHECK(X) ;Check intermediate file for existing entries in selected time frame
;if entries exist quit.
N FILE S FILE=""
S FILE=$S(X="IV":728.113,1:728.904)
I $O(^ECX(FILE,"A",STDATE-.001))&($O(^(STDATE-.001))'>ENDDATE) D Q 0
.W !!!,?3,"******* Entries in file "_$S(X="IV":"(#728.113)",1:"(#728.904)")_" exist for selected time frame ****** "
.W !,?10,"****** Please purge entries before proceeding!!!! ***** "
Q 1
;
IV ;Process iv records to be recreated for intermediate file
;init variables
N DATE,DFN,ON,PSIVNOW,PSIVI,PSIVQTY,PSIVC,LABN
;$order thru ^PS(55,"AIV",dtorder,dfn,on) to regenerate data
S DATE=STDATE-.001,ENDDATE=ENDDATE_.9999
S DATE=0 F S DATE=$O(^PS(55,"AIV",DATE)) Q:'DATE D
.S DFN=0 F S DFN=$O(^PS(55,"AIV",DATE,DFN)) Q:'DFN D
..S ON=0 F S ON=$O(^PS(55,"AIV",DATE,DFN,ON)) Q:'ON D
...S LABN=0 F S LABN=$O(^PS(55,DFN,"IV",ON,"LAB",LABN)) Q:'LABN D
....S PSIVC=$P($G(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,3)
....S PSIVNOW=$P($G(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,2)
....Q:PSIVNOW<STDATE!(PSIVNOW>ENDDATE)
....S PSIVQTY=$P($G(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,5) I +PSIVQTY=0 S PSIVQTY=1
....F PSIVI=1:1:PSIVQTY D IVUPDATE
Q
;
UD ;Process ud records to be recreated for intermediate file
;init variables
N DATE,DFN,ON,DISP,NODE,DRUG,QTY,COST,WARD,PROVIDER,HOW,PSGSTRT,DDATE
;$order thru ^PS(55,5,"AUS",stop date/time,on) to regenerate data
S DATE=STDATE-.001,ENDDATE=ENDDATE_.9999,(DFN,COUNT)=0
F S DFN=$O(^PS(55,DFN)) Q:'DFN D
.S DATE=0
.F S DATE=$O(^PS(55,DFN,5,"AUS",DATE)) Q:'DATE D
..S ON=0 F S ON=$O(^PS(55,DFN,5,"AUS",DATE,ON)) Q:ON'>0 D
...;Look at dispense log multiple 55.0611 check disp field (#.01)
...S DISP=0 F S DISP=$O(^PS(55,DFN,5,ON,11,DISP)) Q:DISP'>0 D
....S NODE=$G(^PS(55,DFN,5,ON,11,DISP,0)) Q:NODE=""
....S PSGSTRT=$P($G(^PS(55,DFN,5,ON,2)),"^",2)
....S DDATE=$P(NODE,U),DRUG=+$P(NODE,U,2),QTY=$P(NODE,U,3),COST=$P(NODE,U,4),WARD=$P(NODE,U,7),PROVIDER=$P(NODE,U,8),HOW=$P(NODE,5)
....Q:DDATE<STDATE!(DDATE>ENDDATE)
....D UDUPDATE
Q
;
IVUPDATE ;Update dss intermediate file (#728.113)
S X="ECXPIV1" X ^%ZOSF("TEST") Q:'$T
N X,PROV,TYP,START,A,IVROOM,B,DSDATE,DRGTYP,DRG,ND,ADSTR,ADUNITS,SOLSTR,DDRG,DCST,Y,ECUD
K ^TMP($J)
S X=$G(^PS(55,DFN,"IV",+ON,0)),PROV=$P(X,U,6),TYP=$P(X,U,4),START=$P(X,U,2)
S A=$G(^PS(55,DFN,"IV",+ON,2)),IVROOM=$P(A,"^",2),B=$G(^PS(55,DFN,"IV",+ON,4)),DSDATE=$S($P(B,"^",2)]"":$P(B,"^",2),1:$P(A,"^"))
F DRGTYP="AD","SOL" F DRG=0:0 S DRG=$O(^PS(55,DFN,"IV",+ON,DRGTYP,DRG)) Q:'DRG D
.S ND=$G(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0)),(ADSTR,ADUNITS,SOLSTR)=""
.S @(DRGTYP_"STR")=$P(ND,U,2),ND=$G(^PS($S(DRGTYP="AD":52.6,1:52.7),+ND,0)),DDRG=$P(ND,U,2),DCST=$P(ND,U,7)
.I DRGTYP="AD" S Y=$P(ND,U,3) I Y S Y=$$CODES^PSIVUTL(Y,52.6,2) S ADUNITS=Y
.S ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
.S ECUD=ECUD_U_$P($G(^PS(55,DFN,"IV",+ON,"DSS")),"^")_U_START_U_IVROOM_U_DSDATE S ^TMP($J,DFN,ON,DDRG)=ECUD D ^ECXPIV1 S COUNT=$G(COUNT)+1
Q
;
UDUPDATE ;Update unit dose extract data file (#728.904)
S X="ECXUD1" X ^%ZOSF("TEST") Q:'$T
S ECUD=DFN_"^"_DDATE_"^"_DRUG_"^"_QTY_"^"_WARD_"^"_PROVIDER_";200^"_COST_"^"_PSGSTRT_"^"_ON D ^ECXUD1 S COUNT=$G(COUNT)+1
Q
;
MSG ; send message to mail group 'DSS-ECGRP'
N XMSUB,XMDUZ,XMY,ECMSG,XMTEXT,ECGRP
S XMSUB=EXTRACT_" INTERMEDIATE DATA FOR DSS"
S XMDUZ="DSS SYSTEM",ECGRP=$S(EXTRACT="IV":"IV",1:"UD")
K XMY S XMY("G.DSS-"_ECGRP)=""
S ECMSG(1,0)="The "_EXTRACT_" information has been successfully regenerated"
S ECMSG(2,0)="from "_$$FMTE^XLFDT(STDATE)_" to "_$$FMTE^XLFDT(ENDDATE)
S ECMSG(3,0)=" "
S ECMSG(4,0)="A total of "_COUNT_" records were written."
S ECMSG(5,0)=" "
S XMTEXT="ECMSG("
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJDSS 5511 printed Sep 23, 2025@19:42:52 Page 2
PSJDSS ;ALB/JRC-REGENERATE DSS EXTRACT DATA FILE (#728.113) & (728.904) ; 10/8/08 1:53pm
+1 ;;5.0; INPATIENT MEDICATIONS ;**210**;16 DEC 97;Build 27
+2 QUIT
+3 ;
+4 ;This routine was written to regenerate lost IV or UD data that is
+5 ;normally stored in DSS intermediate files (#728.113) and (#728.904).
+6 ;When this routine is invoked the users are prompted for a date range
+7 ;The routine then loops thru the "AIV" xref in the case of IV or the
+8 ;"AUS" xref in the case of UD, validates the orders and regenerates
+9 ;the records.
+10 ;
+11 ;Important Note: If the entries for a given range are not cleared the
+12 ; file is going to end with duplicates, so a check is
+13 ; done on file (#728.113) or (#728.904) to see if any
+14 ; entries exist, if they do, the program quits.
+15 ;
+16 ; Input: EXTRACT = "IV" or "UD"
+17 ;
EN ;Entry Point
+1 ;Check input
+2 if '$GET(EXTRACT)=""
QUIT
+3 NEW STDATE,ENDDATE
+4 ;Get start and stop dates
+5 if '$$DATE()
QUIT
+6 if '$$CHECK(EXTRACT)
QUIT
+7 SET ZTDESC=EXTRACT_" EXTRACT DATA FILE: "_STDATE_" TO "_ENDDATE_" RECOMPILE"
SET ZTRTN="START^PSJDSS"
SET ZTIO=""
+8 FOR I="EXTRACT","STDATE","ENDDATE"
SET ZTSAVE(I)=""
+9 DO ^%ZTLOAD
+10 IF $DATA(ZTSK)
Begin DoDot:1
+11 WRITE !,"Request queued as Task #",ZTSK,".",!
End DoDot:1
+12 QUIT
START ;Start recompile after queue
+1 NEW COUNT
+2 ;Process records and update intermediate file
+3 DO @EXTRACT
+4 ;Send completion message
+5 DO MSG
+6 ;verify ^tmp global is deleted
+7 KILL ^TMP($JOB)
+8 QUIT
+9 ;
DATE() ;Prompt user for start date
+1 NEW DIR,X,Y,DIRUT
+2 SET DIR(0)="D"
+3 SET DIR("A")="Enter Start Date"
+4 DO ^DIR
+5 IF $DATA(DIRUT)
QUIT 0
+6 SET STDATE=Y
+7 ;Prompt user for end date
+8 KILL DIR,X,Y
+9 SET DIR(0)="D"
+10 SET DIR("A")="Enter Stop Date"
+11 DO ^DIR
+12 IF $DATA(DIRUT)
QUIT 0
+13 SET ENDDATE=Y
+14 QUIT 1
+15 ;
CHECK(X) ;Check intermediate file for existing entries in selected time frame
+1 ;if entries exist quit.
+2 NEW FILE
SET FILE=""
+3 SET FILE=$SELECT(X="IV":728.113,1:728.904)
+4 IF $ORDER(^ECX(FILE,"A",STDATE-.001))&($ORDER(^(STDATE-.001))'>ENDDATE)
Begin DoDot:1
+5 WRITE !!!,?3,"******* Entries in file "_$SELECT(X="IV":"(#728.113)",1:"(#728.904)")_" exist for selected time frame ****** "
+6 WRITE !,?10,"****** Please purge entries before proceeding!!!! ***** "
End DoDot:1
QUIT 0
+7 QUIT 1
+8 ;
IV ;Process iv records to be recreated for intermediate file
+1 ;init variables
+2 NEW DATE,DFN,ON,PSIVNOW,PSIVI,PSIVQTY,PSIVC,LABN
+3 ;$order thru ^PS(55,"AIV",dtorder,dfn,on) to regenerate data
+4 SET DATE=STDATE-.001
SET ENDDATE=ENDDATE_.9999
+5 SET DATE=0
FOR
SET DATE=$ORDER(^PS(55,"AIV",DATE))
if 'DATE
QUIT
Begin DoDot:1
+6 SET DFN=0
FOR
SET DFN=$ORDER(^PS(55,"AIV",DATE,DFN))
if 'DFN
QUIT
Begin DoDot:2
+7 SET ON=0
FOR
SET ON=$ORDER(^PS(55,"AIV",DATE,DFN,ON))
if 'ON
QUIT
Begin DoDot:3
+8 SET LABN=0
FOR
SET LABN=$ORDER(^PS(55,DFN,"IV",ON,"LAB",LABN))
if 'LABN
QUIT
Begin DoDot:4
+9 SET PSIVC=$PIECE($GET(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,3)
+10 SET PSIVNOW=$PIECE($GET(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,2)
+11 if PSIVNOW<STDATE!(PSIVNOW>ENDDATE)
QUIT
+12 SET PSIVQTY=$PIECE($GET(^PS(55,DFN,"IV",ON,"LAB",LABN,0)),U,5)
IF +PSIVQTY=0
SET PSIVQTY=1
+13 FOR PSIVI=1:1:PSIVQTY
DO IVUPDATE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
UD ;Process ud records to be recreated for intermediate file
+1 ;init variables
+2 NEW DATE,DFN,ON,DISP,NODE,DRUG,QTY,COST,WARD,PROVIDER,HOW,PSGSTRT,DDATE
+3 ;$order thru ^PS(55,5,"AUS",stop date/time,on) to regenerate data
+4 SET DATE=STDATE-.001
SET ENDDATE=ENDDATE_.9999
SET (DFN,COUNT)=0
+5 FOR
SET DFN=$ORDER(^PS(55,DFN))
if 'DFN
QUIT
Begin DoDot:1
+6 SET DATE=0
+7 FOR
SET DATE=$ORDER(^PS(55,DFN,5,"AUS",DATE))
if 'DATE
QUIT
Begin DoDot:2
+8 SET ON=0
FOR
SET ON=$ORDER(^PS(55,DFN,5,"AUS",DATE,ON))
if ON'>0
QUIT
Begin DoDot:3
+9 ;Look at dispense log multiple 55.0611 check disp field (#.01)
+10 SET DISP=0
FOR
SET DISP=$ORDER(^PS(55,DFN,5,ON,11,DISP))
if DISP'>0
QUIT
Begin DoDot:4
+11 SET NODE=$GET(^PS(55,DFN,5,ON,11,DISP,0))
if NODE=""
QUIT
+12 SET PSGSTRT=$PIECE($GET(^PS(55,DFN,5,ON,2)),"^",2)
+13 SET DDATE=$PIECE(NODE,U)
SET DRUG=+$PIECE(NODE,U,2)
SET QTY=$PIECE(NODE,U,3)
SET COST=$PIECE(NODE,U,4)
SET WARD=$PIECE(NODE,U,7)
SET PROVIDER=$PIECE(NODE,U,8)
SET HOW=$PIECE(NODE,5)
+14 if DDATE<STDATE!(DDATE>ENDDATE)
QUIT
+15 DO UDUPDATE
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
IVUPDATE ;Update dss intermediate file (#728.113)
+1 SET X="ECXPIV1"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+2 NEW X,PROV,TYP,START,A,IVROOM,B,DSDATE,DRGTYP,DRG,ND,ADSTR,ADUNITS,SOLSTR,DDRG,DCST,Y,ECUD
+3 KILL ^TMP($JOB)
+4 SET X=$GET(^PS(55,DFN,"IV",+ON,0))
SET PROV=$PIECE(X,U,6)
SET TYP=$PIECE(X,U,4)
SET START=$PIECE(X,U,2)
+5 SET A=$GET(^PS(55,DFN,"IV",+ON,2))
SET IVROOM=$PIECE(A,"^",2)
SET B=$GET(^PS(55,DFN,"IV",+ON,4))
SET DSDATE=$SELECT($PIECE(B,"^",2)]"":$PIECE(B,"^",2),1:$PIECE(A,"^"))
+6 FOR DRGTYP="AD","SOL"
FOR DRG=0:0
SET DRG=$ORDER(^PS(55,DFN,"IV",+ON,DRGTYP,DRG))
if 'DRG
QUIT
Begin DoDot:1
+7 SET ND=$GET(^PS(55,DFN,"IV",+ON,DRGTYP,DRG,0))
SET (ADSTR,ADUNITS,SOLSTR)=""
+8 SET @(DRGTYP_"STR")=$PIECE(ND,U,2)
SET ND=$GET(^PS($SELECT(DRGTYP="AD":52.6,1:52.7),+ND,0))
SET DDRG=$PIECE(ND,U,2)
SET DCST=$PIECE(ND,U,7)
+9 IF DRGTYP="AD"
SET Y=$PIECE(ND,U,3)
IF Y
SET Y=$$CODES^PSIVUTL(Y,52.6,2)
SET ADUNITS=Y
+10 SET ECUD=DFN_U_+ON_U_DDRG_U_PSIVNOW_U_PSIVC_U_ADSTR_U_ADUNITS_U_+SOLSTR_U_PROV_U_TYP_U_DCST
+11 SET ECUD=ECUD_U_$PIECE($GET(^PS(55,DFN,"IV",+ON,"DSS")),"^")_U_START_U_IVROOM_U_DSDATE
SET ^TMP($JOB,DFN,ON,DDRG)=ECUD
DO ^ECXPIV1
SET COUNT=$GET(COUNT)+1
End DoDot:1
+12 QUIT
+13 ;
UDUPDATE ;Update unit dose extract data file (#728.904)
+1 SET X="ECXUD1"
XECUTE ^%ZOSF("TEST")
if '$TEST
QUIT
+2 SET ECUD=DFN_"^"_DDATE_"^"_DRUG_"^"_QTY_"^"_WARD_"^"_PROVIDER_";200^"_COST_"^"_PSGSTRT_"^"_ON
DO ^ECXUD1
SET COUNT=$GET(COUNT)+1
+3 QUIT
+4 ;
MSG ; send message to mail group 'DSS-ECGRP'
+1 NEW XMSUB,XMDUZ,XMY,ECMSG,XMTEXT,ECGRP
+2 SET XMSUB=EXTRACT_" INTERMEDIATE DATA FOR DSS"
+3 SET XMDUZ="DSS SYSTEM"
SET ECGRP=$SELECT(EXTRACT="IV":"IV",1:"UD")
+4 KILL XMY
SET XMY("G.DSS-"_ECGRP)=""
+5 SET ECMSG(1,0)="The "_EXTRACT_" information has been successfully regenerated"
+6 SET ECMSG(2,0)="from "_$$FMTE^XLFDT(STDATE)_" to "_$$FMTE^XLFDT(ENDDATE)
+7 SET ECMSG(3,0)=" "
+8 SET ECMSG(4,0)="A total of "_COUNT_" records were written."
+9 SET ECMSG(5,0)=" "
+10 SET XMTEXT="ECMSG("
+11 DO ^XMD
+12 QUIT
