- MDSTUDL ; HOIFO/NCA - Clinical Procedures Studies List ;10/26/05 11:46
- ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
- ; Integration Agreements:
- ; IA# 3468 [Subscription] Use GMRCCP APIs.
- ; IA# 2263 [Supported] XPAR calls
- ; IA# 10103 [Supported] XLFDT calls
- ; IA# 10061 [Supported] VADPT calls
- ; IA# 10062 [Supported] VADPT6 calls
- ; IA# 4869 [Private] ^DIC(45.7,
- ;
- EN2 ; Print the Clinical Procedures Studies List
- N DIC,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 !
- W !!,"The report requires a 132 column printer."
- W ! K IOP S %ZIS="MQ",%ZIS("A")="Select LIST Printer: " 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^MDSTUDL",ZTREQ="@",ZTSAVE("ZTREQ")="",ZTSAVE("MDSPEC")=""
- S:$D(XQY0) ZTDESC=$P(XQY0,"^",1)
- D ^%ZTLOAD D ^%ZISC U IO W !,"Request Queued",! K ZTSK Q
- GETTRAN ; [Procedure] Get a patients transactions
- K ^TMP("MDSTUDL",$J),^TMP("MDINST",$J)
- N BID,DFN,DTP,LN,MDCHKD,MDCHKDT,MDCOM,MDCOMP,MDDEFN,MDMULT,MDNUM,MDPNAM,MDREQ,MDREQDT,MDANOD,MDBNOD,MDCNOD,MDSP,MDTXT,MDURG,MDYR,PG,RESLT,X1,X2,X,Y0
- S RESLT=$NA(^TMP("MDCONL",$J)),LN="",$P(LN,"-",131)="",MDCOM=0
- S PG=0 N % D NOW^%DTC S DTP=%,DTP=$$FMTE^XLFDT(DTP,"1P")
- S MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1)
- I +MDNUM>0 S X1=DT,X2=-MDNUM D C^%DTC S MDCOM=X
- S X1=DT,X2=-365 D C^%DTC S MDYR=X
- F DFN=0:0 S DFN=$O(^MDD(702,"B",DFN)) Q:'DFN D
- .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
- .K @RESLT D GETCON(.RESLT,DFN)
- .F MDX=0:0 S MDX=$O(^MDD(702,"B",DFN,+MDX))_"," Q:'MDX D
- ..S (MDANOD,MDCNOD)=""
- ..Q:'$$GET1^DIQ(702,MDX,.05,"I")
- ..Q:$G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I")))=""
- ..S MDMULT=$$GET1^DIQ(702,MDX,".04:.12","I")
- ..S MDCOMP=$S(+MDMULT<1:MDCOM,1:MDYR)
- ..I MDNUM Q:$$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDCOMP)
- ..S MDREQDT="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDREQDT=$P($G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I"))),U)
- ..I MDREQDT'="" S MDREQDT=$$FMTE^XLFDT(MDREQDT,"2P")
- ..S MDURG="" I +$$GET1^DIQ(702,MDX,.05,"I") S MDURG=$P($G(^TMP("MDCONL",$J,+$$GET1^DIQ(702,MDX,.05,"I"))),U,2)
- ..S MDREQ=$$GET1^DIQ(702,MDX,.04) S:$L(MDREQ)>25 MDREQ=$E(MDREQ,1,25)
- ..S (MDCHKD,MDCHKDT)=$$GET1^DIQ(702,MDX,.02,"I"),MDCHKDT=$$FMTE^XLFDT(MDCHKDT,"2P")
- ..S Z=MDREQ_U_MDCHKDT_U_$$GET1^DIQ(702,MDX,.05,"I")_U_MDREQDT_U_$$GET1^DIQ(702,MDX,.09)_U_MDURG
- ..S MDANOD="UNASSIGNED",MDSP=+$$GET1^DIQ(702,MDX,".04:.02","I")
- ..I +MDSP Q:+MDSPEC>0&(+MDSPEC'=+MDSP) S MDANOD=$$GET1^DIQ(702,MDX,".04:.02")
- ..S MDANOD=MDANOD_"~"_$$GET1^DIQ(702,MDX,.11)
- ..S:'$D(^TMP("MDINST",$J,MDANOD)) ^TMP("MDINST",$J,MDANOD)=+MDSP_"^"_$$GET1^DIQ(702,MDX,.11,"I")
- ..I +$$GET1^DIQ(702,MDX,.04,"I") S MDDEFN=$$GET1^DIQ(702,MDX,.04),MDCNOD=MDDEFN_"~"_MDBNOD
- ..S ^TMP("MDSTUDL",$J,+MDSP,+$$GET1^DIQ(702,MDX,.11,"I"),MDCNOD,MDCHKD)=Z
- N MDCT S MDCT=0
- N MDLOP S MDLOP="" F S MDLOP=$O(^TMP("MDINST",$J,MDLOP)) Q:MDLOP="" S MDSUBS=$G(^(MDLOP)) D
- .D HDR
- .S MDANOD="" F S MDANOD=$O(^TMP("MDSTUDL",$J,+MDSUBS,+$P(MDSUBS,U,2),MDANOD)) Q:MDANOD="" S MDBNOD="" F S MDBNOD=$O(^TMP("MDSTUDL",$J,+MDSUBS,+$P(MDSUBS,U,2),MDANOD,MDBNOD)) Q:MDBNOD="" D
- ..S Y0=$G(^TMP("MDSTUDL",$J,+MDSUBS,+$P(MDSUBS,U,2),MDANOD,MDBNOD))
- ..D:$Y>(IOSL-8) HDR
- ..W !,$P(MDANOD,"~",2),?25,$P(MDANOD,"~",3),?31,$P(Y0,U,3),?45,$P(Y0,U,4),?67,$S($L($P(Y0,U,6))>10:$E($P(Y0,U,6),1,10),1:$P(Y0,U,6)),?78,$P(Y0,U),?104,$E($P(Y0,U,5),1,5),?111,$P(Y0,U,2),!
- K ^TMP("MDSTUDL",$J),^TMP("MDCONL",$J),^TMP("MDINST",$J)
- Q
- GETCON(RESLT,DFN) ; Get Consult
- K ^TMP("MDTMPL",$J) N MDCDT,X1,X2,X
- S X1=DT,X2=-365 D C^%DTC S MDCDT=X
- D CPLIST^GMRCCP(DFN,,$NA(^TMP("MDTMPL",$J)))
- S MDX=0 F S MDX=$O(^TMP("MDTMPL",$J,MDX)) Q:'MDX D:"saprc"[$P(^(MDX),U,4)
- .I $P($G(^TMP("MDTMP",$J,MDX)),U,4)="c" Q:$P($G(^TMP("MDTMP",$J,MDX)),U,1)<MDCDT
- .S @RESLT@($P($G(^TMP("MDTMPL",$J,MDX)),U,5))=$P($G(^TMP("MDTMPL",$J,MDX)),U,1)_"^"_$P($G(^TMP("MDTMPL",$J,MDX)),U,3) Q
- K ^TMP("MDTMPL",$J)
- Q
- HDR ; List Header
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
- W !,DTP,?43,"C L I N I C A L P R O C E D U R E S S T U D I E S L I S T",?125,"Page ",PG,!
- S Y=$S($P(MDLOP,"~")="UNASSIGNED":"",1:$P(MDLOP,"~")) W:Y'="" !!?(131-$L(Y)\2),Y
- W !!,$P(MDLOP,"~",2) S Y="",$P(Y,"=",$L($P(MDLOP,"~",2))+1)="" W !,Y,!
- W !?47,"Reqd.",?106,"CP",?113,"Check-In",!,"Patient",?25,"ID#",?31,"Consult #",?45,"Date/Time",?67,"Urgency",?78,"Procedure",?104,"Status",?113,"Date/Time",!,LN,!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMDSTUDL 4889 printed Mar 13, 2025@20:49 Page 2
- MDSTUDL ; HOIFO/NCA - Clinical Procedures Studies List ;10/26/05 11:46
- +1 ;;1.0;CLINICAL PROCEDURES;**6**;Apr 01, 2004;Build 102
- +2 ; Integration Agreements:
- +3 ; IA# 3468 [Subscription] Use GMRCCP APIs.
- +4 ; IA# 2263 [Supported] XPAR calls
- +5 ; IA# 10103 [Supported] XLFDT calls
- +6 ; IA# 10061 [Supported] VADPT calls
- +7 ; IA# 10062 [Supported] VADPT6 calls
- +8 ; IA# 4869 [Private] ^DIC(45.7,
- +9 ;
- EN2 ; Print the Clinical Procedures Studies List
- +1 NEW DIC,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 WRITE !!,"The report requires a 132 column printer."
- +3 WRITE !
- KILL IOP
- SET %ZIS="MQ"
- SET %ZIS("A")="Select LIST Printer: "
- WRITE !
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- QUIT
- +4 IF $DATA(IO("Q"))
- DO QUE
- QUIT
- +5 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^MDSTUDL"
- SET ZTREQ="@"
- SET ZTSAVE("ZTREQ")=""
- SET ZTSAVE("MDSPEC")=""
- +2 if $DATA(XQY0)
- SET ZTDESC=$PIECE(XQY0,"^",1)
- +3 DO ^%ZTLOAD
- DO ^%ZISC
- USE IO
- WRITE !,"Request Queued",!
- KILL ZTSK
- QUIT
- GETTRAN ; [Procedure] Get a patients transactions
- +1 KILL ^TMP("MDSTUDL",$JOB),^TMP("MDINST",$JOB)
- +2 NEW BID,DFN,DTP,LN,MDCHKD,MDCHKDT,MDCOM,MDCOMP,MDDEFN,MDMULT,MDNUM,MDPNAM,MDREQ,MDREQDT,MDANOD,MDBNOD,MDCNOD,MDSP,MDTXT,MDURG,MDYR,PG,RESLT,X1,X2,X,Y0
- +3 SET RESLT=$NAME(^TMP("MDCONL",$JOB))
- SET LN=""
- SET $PIECE(LN,"-",131)=""
- SET MDCOM=0
- +4 SET PG=0
- NEW %
- DO NOW^%DTC
- SET DTP=%
- SET DTP=$$FMTE^XLFDT(DTP,"1P")
- +5 SET MDNUM=$$GET^XPAR("SYS","MD DAYS TO RETAIN COM STUDY",1)
- +6 IF +MDNUM>0
- SET X1=DT
- SET X2=-MDNUM
- DO C^%DTC
- SET MDCOM=X
- +7 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET MDYR=X
- +8 FOR DFN=0:0
- SET DFN=$ORDER(^MDD(702,"B",DFN))
- if 'DFN
- QUIT
- Begin DoDot:1
- +9 DO DEM^VADPT
- SET MDPNAM=$GET(VADM(1))
- KILL VADM
- DO PID^VADPT6
- SET BID=$GET(VA("BID"))
- KILL VA
- +10 SET MDBNOD=$SELECT($LENGTH(MDPNAM)>24:$EXTRACT(MDPNAM,1,24),1:MDPNAM)_"~"_BID
- +11 KILL @RESLT
- DO GETCON(.RESLT,DFN)
- +12 FOR MDX=0:0
- SET MDX=$ORDER(^MDD(702,"B",DFN,+MDX))_","
- if 'MDX
- QUIT
- Begin DoDot:2
- +13 SET (MDANOD,MDCNOD)=""
- +14 if '$$GET1^DIQ(702,MDX,.05,"I")
- QUIT
- +15 if $GET(^TMP("MDCONL",$JOB,+$$GET1^DIQ(702,MDX,.05,"I")))=""
- QUIT
- +16 SET MDMULT=$$GET1^DIQ(702,MDX,".04:.12","I")
- +17 SET MDCOMP=$SELECT(+MDMULT<1:MDCOM,1:MDYR)
- +18 IF MDNUM
- if $$GET1^DIQ(702,MDX,.09,"I")=3&($$GET1^DIQ(702,MDX,.02,"I")<MDCOMP)
- QUIT
- +19 SET MDREQDT=""
- IF +$$GET1^DIQ(702,MDX,.05,"I")
- SET MDREQDT=$PIECE($GET(^TMP("MDCONL",$JOB,+$$GET1^DIQ(702,MDX,.05,"I"))),U)
- +20 IF MDREQDT'=""
- SET MDREQDT=$$FMTE^XLFDT(MDREQDT,"2P")
- +21 SET MDURG=""
- IF +$$GET1^DIQ(702,MDX,.05,"I")
- SET MDURG=$PIECE($GET(^TMP("MDCONL",$JOB,+$$GET1^DIQ(702,MDX,.05,"I"))),U,2)
- +22 SET MDREQ=$$GET1^DIQ(702,MDX,.04)
- if $LENGTH(MDREQ)>25
- SET MDREQ=$EXTRACT(MDREQ,1,25)
- +23 SET (MDCHKD,MDCHKDT)=$$GET1^DIQ(702,MDX,.02,"I")
- SET MDCHKDT=$$FMTE^XLFDT(MDCHKDT,"2P")
- +24 SET Z=MDREQ_U_MDCHKDT_U_$$GET1^DIQ(702,MDX,.05,"I")_U_MDREQDT_U_$$GET1^DIQ(702,MDX,.09)_U_MDURG
- +25 SET MDANOD="UNASSIGNED"
- SET MDSP=+$$GET1^DIQ(702,MDX,".04:.02","I")
- +26 IF +MDSP
- if +MDSPEC>0&(+MDSPEC'=+MDSP)
- QUIT
- SET MDANOD=$$GET1^DIQ(702,MDX,".04:.02")
- +27 SET MDANOD=MDANOD_"~"_$$GET1^DIQ(702,MDX,.11)
- +28 if '$DATA(^TMP("MDINST",$JOB,MDANOD))
- SET ^TMP("MDINST",$JOB,MDANOD)=+MDSP_"^"_$$GET1^DIQ(702,MDX,.11,"I")
- +29 IF +$$GET1^DIQ(702,MDX,.04,"I")
- SET MDDEFN=$$GET1^DIQ(702,MDX,.04)
- SET MDCNOD=MDDEFN_"~"_MDBNOD
- +30 SET ^TMP("MDSTUDL",$JOB,+MDSP,+$$GET1^DIQ(702,MDX,.11,"I"),MDCNOD,MDCHKD)=Z
- End DoDot:2
- End DoDot:1
- +31 NEW MDCT
- SET MDCT=0
- +32 NEW MDLOP
- SET MDLOP=""
- FOR
- SET MDLOP=$ORDER(^TMP("MDINST",$JOB,MDLOP))
- if MDLOP=""
- QUIT
- SET MDSUBS=$GET(^(MDLOP))
- Begin DoDot:1
- +33 DO HDR
- +34 SET MDANOD=""
- FOR
- SET MDANOD=$ORDER(^TMP("MDSTUDL",$JOB,+MDSUBS,+$PIECE(MDSUBS,U,2),MDANOD))
- if MDANOD=""
- QUIT
- SET MDBNOD=""
- FOR
- SET MDBNOD=$ORDER(^TMP("MDSTUDL",$JOB,+MDSUBS,+$PIECE(MDSUBS,U,2),MDANOD,MDBNOD))
- if MDBNOD=""
- QUIT
- Begin DoDot:2
- +35 SET Y0=$GET(^TMP("MDSTUDL",$JOB,+MDSUBS,+$PIECE(MDSUBS,U,2),MDANOD,MDBNOD))
- +36 if $Y>(IOSL-8)
- DO HDR
- +37 WRITE !,$PIECE(MDANOD,"~",2),?25,$PIECE(MDANOD,"~",3),?31,$PIECE(Y0,U,3),?45,$PIECE(Y0,U,4),?67,$SELECT($LENGTH($PIECE(Y0,U,6))>10:$EXTRACT($PIECE(Y0,U,6),1,10),1:$PIECE(Y0,U,6)),?78,$PIECE(Y0,U),?104,$EXTRACT($PIECE(Y0,U,5)
- ,1,5),?111,$PIECE(Y0,U,2),!
- End DoDot:2
- End DoDot:1
- +38 KILL ^TMP("MDSTUDL",$JOB),^TMP("MDCONL",$JOB),^TMP("MDINST",$JOB)
- +39 QUIT
- GETCON(RESLT,DFN) ; Get Consult
- +1 KILL ^TMP("MDTMPL",$JOB)
- NEW MDCDT,X1,X2,X
- +2 SET X1=DT
- SET X2=-365
- DO C^%DTC
- SET MDCDT=X
- +3 DO CPLIST^GMRCCP(DFN,,$NAME(^TMP("MDTMPL",$JOB)))
- +4 SET MDX=0
- FOR
- SET MDX=$ORDER(^TMP("MDTMPL",$JOB,MDX))
- if 'MDX
- QUIT
- if "saprc"[$PIECE(^(MDX),U,4)
- Begin DoDot:1
- +5 IF $PIECE($GET(^TMP("MDTMP",$JOB,MDX)),U,4)="c"
- if $PIECE($GET(^TMP("MDTMP",$JOB,MDX)),U,1)<MDCDT
- QUIT
- +6 SET @RESLT@($PIECE($GET(^TMP("MDTMPL",$JOB,MDX)),U,5))=$PIECE($GET(^TMP("MDTMPL",$JOB,MDX)),U,1)_"^"_$PIECE($GET(^TMP("MDTMPL",$JOB,MDX)),U,3)
- QUIT
- End DoDot:1
- +7 KILL ^TMP("MDTMPL",$JOB)
- +8 QUIT
- HDR ; List Header
- +1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- +2 WRITE !,DTP,?43,"C L I N I C A L P R O C E D U R E S S T U D I E S L I S T",?125,"Page ",PG,!
- +3 SET Y=$SELECT($PIECE(MDLOP,"~")="UNASSIGNED":"",1:$PIECE(MDLOP,"~"))
- if Y'=""
- WRITE !!?(131-$LENGTH(Y)\2),Y
- +4 WRITE !!,$PIECE(MDLOP,"~",2)
- SET Y=""
- SET $PIECE(Y,"=",$LENGTH($PIECE(MDLOP,"~",2))+1)=""
- WRITE !,Y,!
- +5 WRITE !?47,"Reqd.",?106,"CP",?113,"Check-In",!,"Patient",?25,"ID#",?31,"Consult #",?45,"Date/Time",?67,"Urgency",?78,"Procedure",?104,"Status",?113,"Date/Time",!,LN,!
- +6 QUIT
