MDSTUDW.m

MDSTUDW ; HOIFO/NCA - Print a List of Procedures With Incomplete Workload ;3/2/09  10:00

 ;;1.0;CLINICAL PROCEDURES;**21**;Apr 01, 2004;Build 30

 ; Integration Agreements:

 ; IA #1894 [Subscription] PXAPI call

 ; IA# 10103 [Supported] XLFDT calls

 ; IA# 10061 [Supported] VADPT calls

 ; IA# 10062 [Supported] VADPT6 calls

 ; IA# 4869 [Private] ^DIC(45.7,

 ;

E1 ; Get Start Date

 N MDSDT,MDEDT

 S %DT("A")="Select Start Date: ",%DT="AEX" W ! D ^%DT G EX:"^"[X!$D(DTOUT),E1:Y<1 S MDSDT=+Y

E2 S %DT("A")="Select End Date: ",%DT="AEX" W ! D ^%DT G EX:"^"[X!$D(DTOUT),E2:Y<1

 I +Y<MDSDT W !!,"***End Date must be on or after Start Date!!!" G E2

 S MDEDT=+Y+.24

EN2 ; Print a list of Procedures with incomplete Workload

 N DIC,MDSPEC,X,Y,DTOUT,DUOUT

S1 R !!,"Select Facility Treating Specialty (or ALL): ",X:DTIME Q:'$T!("^"[X)  S:X="all" X=$TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") I X="ALL" S MDSPEC=0

 E  K DIC S DIC="^DIC(45.7,",DIC(0)="EMQ" D ^DIC G:Y<1!($D(DTOUT))!($D(DUOUT)) S1 S MDSPEC=+Y K DIC W !

 K IOP S %ZIS="MQ",%ZIS("A")="Select LIST Printer: ",%ZIS("B")="HOME" W ! D ^%ZIS K %ZIS,IOP Q:POP

 I $D(IO("Q")) D QUE Q

 U IO D GETTRAN D ^%ZISC K %ZIS,IOP Q

QUE ; Queue List

 K IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE,ZTDESC,ZTSK S ZTRTN="GETTRAN^MDSTUDW",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("MDSPEC")="",ZTSAVE("MDSDT")="",ZTSAVE("MDEDT")=""

 S:$D(XQY0) ZTDESC=$P(XQY0,"^",1)

 D ^%ZTLOAD D ^%ZISC U IO W !,"Request Queued",! K ZTSK Q

EX ; Exit

 Q

GETTRAN ; [Procedure] Loop through Results by Date/Time Performed

 K ^TMP("MDSTUDW",$J)

 N ANS,BID,DFN,DTP,LN,MDL,MDL1,MDCHKD,MDCHKDT,MDCOM,MDCNST,MDCOMP,MDDEFN,MDNUM,MDPNAM,MDREQ,MDANOD,MDBNOD,MDCNOD,MDSP,MDTXT,MDVS,MDVST,MDX,PG,S1,X1,X2,X,Y0,Z

 N MDCT,MDLOP,MDOK,MDOK1,MDOK2,MDVDT S S1=$S(IOST?1"C".E:IOSL-8,1:IOSL-7)

 S LN="",$P(LN,"-",79)="",MDCOM=0

 S PG=0 N % D NOW^%DTC S DTP=%,DTP=$$FMTE^XLFDT(DTP,"1P")

 S MDL=MDSDT F  S MDL=$O(^MDD(703.1,"ADTP",MDL)) Q:'MDL!(MDL>MDEDT)  F MDL1=0:0 S MDL1=$O(^MDD(703.1,"ADTP",MDL,MDL1)) Q:MDL1<1  D

 .S (MDANOD,MDBNOD,MDCNOD)=""

 .S MDCOM=$P($G(^MDD(703.1,+MDL1,0)),"^",5)

 .S MDVST=+$G(^MDD(702,+MDCOM,1)) Q:'MDVST

 .D ENCEVENT^PXAPI(MDVST) S (MDOK,MDOK1,MDOK2)=0

 .I $D(^TMP("PXKENC",$J,MDVST,"POV")) S MDOK=1

 .I $D(^TMP("PXKENC",$J,MDVST,"CPT")) S MDOK1=1

 .I $D(^TMP("PXKENC",$J,MDVST,"PRV")) S MDOK2=1

 .S MDVS=$O(^TMP("PXKENC",$J,MDVST,"VST",0))

 .S MDVDT=$P($G(^TMP("PXKENC",$J,MDVST,"VST",+MDVS,0)),"^",1)

 .K ^TMP("PXKENC",$J)

 .Q:(MDOK+MDOK1+MDOK2)=3

 .S DFN=+$P($G(^MDD(702,+MDCOM,0)),"^") D DEM^VADPT S MDPNAM=$G(VADM(1)) K VADM D PID^VADPT6 S BID=$G(VA("BID")) K VA

 .S MDBNOD=$S($L(MDPNAM)>24:$E(MDPNAM,1,24),1:MDPNAM)_" ("_BID_")",MDCNST=$P($G(^MDD(702,+MDCOM,0)),"^",5)

 .S MDANOD="UNASSIGNED",MDSP=+$$GET1^DIQ(702,+MDCOM,".04:.02","I")

 .I +MDSP Q:+MDSPEC>0&(+MDSPEC'=+MDSP)  S MDANOD=$$GET1^DIQ(702,+MDCOM,".04:.02")

 .I +$$GET1^DIQ(702,+MDCOM,.04,"I") S MDDEFN=$$GET1^DIQ(702,+MDCOM,.04),MDCNOD=MDVDT_"~"_MDBNOD

 .S MDANOD=MDANOD_"~"_MDDEFN

 .S Z=$$FMTE^XLFDT(MDVDT,"2MZ")_"^"_MDCNST_"^"_+$P($G(^MDD(702,+MDCOM,0)),"^",6)_"^"_MDVST_"^"_$S('MDOK:"Diagnosis",1:"")_"^"_$S('MDOK1:"CPT",1:"")_"^"_$S('MDOK2:"Provider",1:"")

 .I '$D(^TMP("MDSTUDW",$J,MDANOD,MDCNOD)) S ^TMP("MDSTUDW",$J,MDANOD,MDCNOD)=Z

 .Q

 I '$D(^TMP("MDSTUDW",$J)) S (ANS,MDANOD,MDLOP)="" D HDR W !!,"No procedures with incomplete workload found."

 N MDCT S MDCT=0,(ANS,MDCHKD)=""

 N MDLOP S MDLOP="" F  S MDLOP=$O(^TMP("MDSTUDW",$J,MDLOP)) Q:MDLOP=""!(ANS="^")  D

 .D HDR

 .S MDANOD="" F  S MDANOD=$O(^TMP("MDSTUDW",$J,MDLOP,MDANOD)) Q:MDANOD=""!(ANS="^")  D

 ..S Y0=$G(^TMP("MDSTUDW",$J,MDLOP,MDANOD))

 ..D:$Y>(IOSL-8) HDR Q:ANS="^"

 ..I MDCHKD'=$P(MDLOP,"~",2) W !,"PROCEDURE: ",$P(MDLOP,"~",2),! S MDCHKD=$P(MDLOP,"~",2)

 ..D:$Y'<S1 PAUSE Q:ANS="^"

 ..W !,$P(Y0,U),?18,$P(MDANOD,"~",2),?52,$P(Y0,U,2),?62,$P(Y0,U,3)

 ..I $P(Y0,U,5)'="" W ?69,$P(Y0,U,5)

 ..I $P(Y0,U,6)'="" W !?69,$P(Y0,U,6)

 ..I $P(Y0,U,7)'="" W !?69,$P(Y0,U,7)

 ..W ! Q

 .Q

 K ^TMP("MDSTUDL",$J)

 Q

HDR ; List Header

 Q:ANS="^"  D:$Y'<S1 PAUSE Q:ANS="^"

 W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1

 W !,DTP,?73,"Page ",PG,!!?5,"P R O C E D U R E S   W I T H   I N C O M P L E T E   W O R K L O A D",!!

 S Y=$S($P(MDLOP,"~")="UNASSIGNED":"",1:$P(MDLOP,"~")) W:Y'="" !?(78-$L(Y)\2),Y,!

 W !,"Visit D/T",?18,"Patient",?50,"Consult #",?62,"TIU #",?69,"MISSING",!,LN

 Q

PAUSE ; Pause For Scroll

 I IOST?1"C".E K DIR S DIR(0)="E",DIR("A")="Enter RETURN to Continue or '^' to Quit Listing"  D ^DIR I 'Y S ANS="^"

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---MDSTUDW   4559     printed  Apr 23, 2025@17:58:48                                                                                                                                                                                                     Page 2

MDSTUDW   ; HOIFO/NCA - Print a List of Procedures With Incomplete Workload ;3/2/09  10:00

 +1       ;;1.0;CLINICAL PROCEDURES;**21**;Apr 01, 2004;Build 30

 +2       ; Integration Agreements:

 +3       ; IA #1894 [Subscription] PXAPI call

 +4       ; IA# 10103 [Supported] XLFDT calls

 +5       ; IA# 10061 [Supported] VADPT calls

 +6       ; IA# 10062 [Supported] VADPT6 calls

 +7       ; IA# 4869 [Private] ^DIC(45.7,

 +8       ;

E1        ; Get Start Date

 +1        NEW MDSDT,MDEDT

 +2        SET %DT("A")="Select Start Date: "

           SET %DT="AEX"

           WRITE !

           DO ^%DT

           if "^"[X!$DATA(DTOUT)

               GOTO EX

           if Y<1

               GOTO E1

           SET MDSDT=+Y

E2         SET %DT("A")="Select End Date: "

           SET %DT="AEX"

           WRITE !

           DO ^%DT

           if "^"[X!$DATA(DTOUT)

               GOTO EX

           if Y<1

               GOTO E2

 +1        IF +Y<MDSDT

               WRITE !!,"***End Date must be on or after Start Date!!!"

               GOTO E2

 +2        SET MDEDT=+Y+.24

EN2       ; Print a list of Procedures with incomplete Workload

 +1        NEW DIC,MDSPEC,X,Y,DTOUT,DUOUT

S1         READ !!,"Select Facility Treating Specialty (or ALL): ",X:DTIME

           if '$TEST!("^"[X)

               QUIT 

           if X="all"

               SET X=$TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")

           IF X="ALL"

               SET MDSPEC=0

 +1       IF '$TEST

               KILL DIC

               SET DIC="^DIC(45.7,"

               SET DIC(0)="EMQ"

               DO ^DIC

               if Y<1!($DATA(DTOUT))!($DATA(DUOUT))

                   GOTO S1

               SET MDSPEC=+Y

               KILL DIC

               WRITE !

 +2        KILL IOP

           SET %ZIS="MQ"

           SET %ZIS("A")="Select LIST Printer: "

           SET %ZIS("B")="HOME"

           WRITE !

           DO ^%ZIS

           KILL %ZIS,IOP

           if POP

               QUIT 

 +3        IF $DATA(IO("Q"))

               DO QUE

               QUIT 

 +4        USE IO

           DO GETTRAN

           DO ^%ZISC

           KILL %ZIS,IOP

           QUIT 

QUE       ; Queue List

 +1        KILL IO("Q"),ZTUCI,ZTDTH,ZTIO,ZTSAVE,ZTDESC,ZTSK

           SET ZTRTN="GETTRAN^MDSTUDW"

           SET ZTREQ="@"

           SET ZTSAVE("ZTREQ")=""

           SET ZTSAVE("MDSPEC")=""

           SET ZTSAVE("MDSDT")=""

           SET ZTSAVE("MDEDT")=""

 +2        if $DATA(XQY0)

               SET ZTDESC=$PIECE(XQY0,"^",1)

 +3        DO ^%ZTLOAD

           DO ^%ZISC

           USE IO

           WRITE !,"Request Queued",!

           KILL ZTSK

           QUIT 

EX        ; Exit

 +1        QUIT 

GETTRAN   ; [Procedure] Loop through Results by Date/Time Performed

 +1        KILL ^TMP("MDSTUDW",$JOB)

 +2        NEW ANS,BID,DFN,DTP,LN,MDL,MDL1,MDCHKD,MDCHKDT,MDCOM,MDCNST,MDCOMP,MDDEFN,MDNUM,MDPNAM,MDREQ,MDANOD,MDBNOD,MDCNOD,MDSP,MDTXT,MDVS,MDVST,MDX,PG,S1,X1,X2,X,Y0,Z

 +3        NEW MDCT,MDLOP,MDOK,MDOK1,MDOK2,MDVDT

           SET S1=$SELECT(IOST?1"C".E:IOSL-8,1:IOSL-7)

 +4        SET LN=""

           SET $PIECE(LN,"-",79)=""

           SET MDCOM=0

 +5        SET PG=0

           NEW %

           DO NOW^%DTC

           SET DTP=%

           SET DTP=$$FMTE^XLFDT(DTP,"1P")

 +6        SET MDL=MDSDT

           FOR 

               SET MDL=$ORDER(^MDD(703.1,"ADTP",MDL))

               if 'MDL!(MDL>MDEDT)

                   QUIT 

               FOR MDL1=0:0

                   SET MDL1=$ORDER(^MDD(703.1,"ADTP",MDL,MDL1))

                   if MDL1<1

                       QUIT 

                   Begin DoDot:1

 +7                    SET (MDANOD,MDBNOD,MDCNOD)=""

 +8                    SET MDCOM=$PIECE($GET(^MDD(703.1,+MDL1,0)),"^",5)

 +9                    SET MDVST=+$GET(^MDD(702,+MDCOM,1))

                       if 'MDVST

                           QUIT 

 +10                   DO ENCEVENT^PXAPI(MDVST)

                       SET (MDOK,MDOK1,MDOK2)=0

 +11                   IF $DATA(^TMP("PXKENC",$JOB,MDVST,"POV"))

                           SET MDOK=1

 +12                   IF $DATA(^TMP("PXKENC",$JOB,MDVST,"CPT"))

                           SET MDOK1=1

 +13                   IF $DATA(^TMP("PXKENC",$JOB,MDVST,"PRV"))

                           SET MDOK2=1

 +14                   SET MDVS=$ORDER(^TMP("PXKENC",$JOB,MDVST,"VST",0))

 +15                   SET MDVDT=$PIECE($GET(^TMP("PXKENC",$JOB,MDVST,"VST",+MDVS,0)),"^",1)

 +16                   KILL ^TMP("PXKENC",$JOB)

 +17                   if (MDOK+MDOK1+MDOK2)=3

                           QUIT 

 +18                   SET DFN=+$PIECE($GET(^MDD(702,+MDCOM,0)),"^")

                       DO DEM^VADPT

                       SET MDPNAM=$GET(VADM(1))

                       KILL VADM

                       DO PID^VADPT6

                       SET BID=$GET(VA("BID"))

                       KILL VA

 +19                   SET MDBNOD=$SELECT($LENGTH(MDPNAM)>24:$EXTRACT(MDPNAM,1,24),1:MDPNAM)_" ("_BID_")"

                       SET MDCNST=$PIECE($GET(^MDD(702,+MDCOM,0)),"^",5)

 +20                   SET MDANOD="UNASSIGNED"

                       SET MDSP=+$$GET1^DIQ(702,+MDCOM,".04:.02","I")

 +21                   IF +MDSP

                           if +MDSPEC>0&(+MDSPEC'=+MDSP)

                               QUIT 

                           SET MDANOD=$$GET1^DIQ(702,+MDCOM,".04:.02")

 +22                   IF +$$GET1^DIQ(702,+MDCOM,.04,"I")

                           SET MDDEFN=$$GET1^DIQ(702,+MDCOM,.04)

                           SET MDCNOD=MDVDT_"~"_MDBNOD

 +23                   SET MDANOD=MDANOD_"~"_MDDEFN

 +24                   SET Z=$$FMTE^XLFDT(MDVDT,"2MZ")_"^"_MDCNST_"^"_+$PIECE($GET(^MDD(702,+MDCOM,0)),"^",6)_"^"_MDVST_"^"_$SELECT('MDOK:"Diagnosis",1:"")_"^"_$SELECT('MDOK1:"CPT",1:"")_"^"_$SELECT('MDOK2:"Provider",1:"")

 +25                   IF '$DATA(^TMP("MDSTUDW",$JOB,MDANOD,MDCNOD))

                           SET ^TMP("MDSTUDW",$JOB,MDANOD,MDCNOD)=Z

 +26                   QUIT 

                   End DoDot:1

 +27       IF '$DATA(^TMP("MDSTUDW",$JOB))

               SET (ANS,MDANOD,MDLOP)=""

               DO HDR

               WRITE !!,"No procedures with incomplete workload found."

 +28       NEW MDCT

           SET MDCT=0

           SET (ANS,MDCHKD)=""

 +29       NEW MDLOP

           SET MDLOP=""

           FOR 

               SET MDLOP=$ORDER(^TMP("MDSTUDW",$JOB,MDLOP))

               if MDLOP=""!(ANS="^")

                   QUIT 

               Begin DoDot:1

 +30               DO HDR

 +31               SET MDANOD=""

                   FOR 

                       SET MDANOD=$ORDER(^TMP("MDSTUDW",$JOB,MDLOP,MDANOD))

                       if MDANOD=""!(ANS="^")

                           QUIT 

                       Begin DoDot:2

 +32                       SET Y0=$GET(^TMP("MDSTUDW",$JOB,MDLOP,MDANOD))

 +33                       if $Y>(IOSL-8)

                               DO HDR

                           if ANS="^"

                               QUIT 

 +34                       IF MDCHKD'=$PIECE(MDLOP,"~",2)

                               WRITE !,"PROCEDURE: ",$PIECE(MDLOP,"~",2),!

                               SET MDCHKD=$PIECE(MDLOP,"~",2)

 +35                       if $Y'<S1

                               DO PAUSE

                           if ANS="^"

                               QUIT 

 +36                       WRITE !,$PIECE(Y0,U),?18,$PIECE(MDANOD,"~",2),?52,$PIECE(Y0,U,2),?62,$PIECE(Y0,U,3)

 +37                       IF $PIECE(Y0,U,5)'=""

                               WRITE ?69,$PIECE(Y0,U,5)

 +38                       IF $PIECE(Y0,U,6)'=""

                               WRITE !?69,$PIECE(Y0,U,6)

 +39                       IF $PIECE(Y0,U,7)'=""

                               WRITE !?69,$PIECE(Y0,U,7)

 +40                       WRITE !

                           QUIT 

                       End DoDot:2

 +41               QUIT 

               End DoDot:1

 +42       KILL ^TMP("MDSTUDL",$JOB)

 +43       QUIT 

HDR       ; List Header

 +1        if ANS="^"

               QUIT 

           if $Y'<S1

               DO PAUSE

           if ANS="^"

               QUIT 

 +2        if '($EXTRACT(IOST,1,2)'="C-"&'PG)

               WRITE @IOF

           SET PG=PG+1

 +3        WRITE !,DTP,?73,"Page ",PG,!!?5,"P R O C E D U R E S   W I T H   I N C O M P L E T E   W O R K L O A D",!!

 +4        SET Y=$SELECT($PIECE(MDLOP,"~")="UNASSIGNED":"",1:$PIECE(MDLOP,"~"))

           if Y'=""

               WRITE !?(78-$LENGTH(Y)\2),Y,!

 +5        WRITE !,"Visit D/T",?18,"Patient",?50,"Consult #",?62,"TIU #",?69,"MISSING",!,LN

 +6        QUIT 

PAUSE     ; Pause For Scroll

 +1        IF IOST?1"C".E

               KILL DIR

               SET DIR(0)="E"

               SET DIR("A")="Enter RETURN to Continue or '^' to Quit Listing"

               DO ^DIR

               IF 'Y

                   SET ANS="^"

 +2        QUIT