PSJDSS.m

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 ---PSJDSS   5511     printed  Feb 18, 2025@23:33:08                                                                                                                                                                                                      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