ORWCV ; SLC/KCM - Background Cover Sheet Load; ; 3/6/08 6:34am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243,282**;Dec 17, 1997;Build 6
;
;
; DBIA 1096 Reference to ^DGPM("ATID1"
; DBIA 1894 Reference to GETENC^PXAPI
; DBIA 1895 Reference to APPT2VST^PXAPI
; DBIA 2096 Reference to ^SD(409.63
; DBIA 2437 Reference to ^DGPM(
; DBIA 2965 Reference to ^DIC(405.1
; DBIA 4011 Access ^XWB(8994)
; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT")
; DBIA 4325 References to AWCMCPR1
; DBIA 10061 Reference to ^UTILITY
; CPRS has a SACC exemption for usage of the variable $ZE
;
START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background
N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX
; Capacity planning timing code uses ORHTIME
S ORHTIME=$H
S LOC=$G(LOC),NODO=";"_$G(NODO),NEWREM=+$G(NEWREM)
D GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q")
S I=0 F S I=$O(ORX(I)) Q:'I I $D(^ORD(101.24,+ORX(I),0)) S SECT(+$P(^(0),"^",2))=$P(ORX(I),"^",2)
D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
S (VAL,BACK,STR,FILE)=""
F S I=$O(ORLIST(I)) Q:'I I $D(^ORD(101.24,$P(ORLIST(I),"^",2),0)) S X0=^(0) D
. Q:$P(X0,"^",8)'="C"
. S X=$P(X0,"^",2)
. I NODO[(";"_X_";") Q ; if in NODO, dont do section
. S STR=STR_X_";"
. I '$G(SECT(X)) S VAL=VAL_X_";" ; load section in foreground
. E S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),"^",2)_";" ; load section in background
Q:BACK=""
S ZTIO="ORW THREAD RESOURCE",ZTRTN="BUILD^ORWCV",ZTDTH=$H
S (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))=""
S ZTDESC="CPRS GUI Background Data Retrieval"
D ^%ZTLOAD I '$D(ZTSK) S VAL=STR Q
S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
K ^XTMP(NODE)
S ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK
; Start capacity planning timing clock - will be stopped in POLL code
I +$G(^KMPTMP("KMPD-CPRS")) S ^KMPTMP("KMPDT","ORWCV",NODE)=$G(ORHTIME)_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
Q
BUILD ; called in background by task manager, expects DFN, JobID
N NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2
S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
I $D(ZTQUEUED) S ZTREQ="@"
I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE) Q ; client no longer polling
I '$D(^XTMP(NODE,0)) Q ; XTMP node has been purged
L +^XTMP(NODE)
S ^XTMP(NODE,"DFN")=DFN
;N $ETRAP,$ESTACK
;S $ETRAP="D ERR^ORWCV Q"
I $L($G(FILE),";")>0 F IFLE=1:1:$L(FILE,";") S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0)) S X0=^(0),X2=$G(^(2)) D
. S ID=$P(X0,"^",2),ENT=$P(X0,"^",6),RTN=$P(X0,"^",5),PARAM1=$P(X2,"^"),PARAM2=$P(X2,"^",2),INODE=$P(X2,"^",5),DETAIL=""
. I $P(X0,"^",18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,"^",18),0)),"^",13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),"^") ;DBIA 4011
. I '$L(INODE) Q
. I '$L(ENT) S LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
. I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
. I '$L($T(@(ENT_"^"_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,"^")_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
. I ID=50 D:$L($T(STRT3^AWCMCPR1)) STRT3^AWCMCPR1 D D:$L($T(END^AWCMCPR1)) END^AWCMCPR1 Q ;Special case for reminders
.. I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC) I 1
.. E D @(ENT_"^"_RTN_"(.LST,DFN)")
.. D LST2XTMP(INODE)
. I $L(PARAM1),$L(PARAM2) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)"),LST2XTMP(INODE) Q
. I $L(PARAM1) D @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)"),LST2XTMP(INODE) Q
. D @(ENT_"^"_RTN_"(.LST,DFN)"),LST2XTMP(INODE)
S ^XTMP(NODE,"DONE")=1
I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE)
L -^XTMP(NODE)
Q
ERR ;Error trap
S $ETRAP="D UNWIND^ORWCV Q"
I $D(NODE) D
. I $D(INODE) S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR D LST2XTMP(INODE)
. S ^XTMP(NODE,"DONE")=1
. L -^XTMP(NODE)
D @^%ZOSF("ERRTN") ;file error
S $ECODE=",UOR70 error during Cover Sheet build,"
Q
UNWIND ;Unwind Error stack
Q:$ESTACK>1 ;pop the stack
;add additional code here, if needed
Q
LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID)
I $G(^XTMP(NODE,"STOP")) Q
N I
I $L($G(DETAIL)) S I=0 F S I=$O(LST(I)) Q:'I S $P(LST(I),"^",12)=DETAIL
K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST
Q
POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts
N I,ILST,ID,NODE,DONE
S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
I '$D(^XTMP(NODE,"DFN")) Q
I ^XTMP(NODE,"DFN")'=DFN S LST(1)="~DONE=1" Q
I $G(^XTMP(NODE,"DONE")) S ILST=ILST+1,LST(ILST)="~DONE=1",DONE=1
F ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT" D
. I '$G(^XTMP(NODE,ID)) Q
. S ILST=ILST+1,LST(ILST)="~"_ID
. S I=0 F S I=$O(^XTMP(NODE,ID,I)) Q:'I S ILST=ILST+1,LST(ILST)="i"_^(I)
. K ^XTMP(NODE,ID)
; Stop capacity planning timing clock - was started in START code
I DONE K ^XTMP(NODE) I +$G(^KMPTMP("KMPD-CPRS")) S $P(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$H
Q
STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval
S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN,ILST=0,DONE=0
S ^XTMP(NODE,"STOP")=1,OK=1
L +^XTMP(NODE)
I $G(^XTMP(NODE,"DONE")) K ^XTMP(NODE)
L -^XTMP(NODE)
Q
CLEAN ; clean up ^XTMP nodes
S X="ORWCV"
F S X=$O(^XTMP(X)) Q:$E(X,1,5)'="ORWCV" W !,X K ^XTMP(X)
Q
LAB(LST,DFN) ; return labs for patient
D:$L($T(STRT2^AWCMCPR1)) STRT2^AWCMCPR1
D LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1)
D:$L($T(END^AWCMCPR1)) END^AWCMCPR1
Q
;
VST1(ORVISIT,DFN,BEG,END,SKIP) ;
N ERR,ERRMSG
S ERR=0 ; kludge to return errors
Q:'$G(DFN)
D VST(.ORVISIT,DFN,.BEG,.END,$G(SKIP),.ERR,.ERRMSG)
I ERR K ORVISIT S ORVISIT(1)=ERRMSG
Q
;
TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1)
Q
VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient
N CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X
S CHECKERR=($G(ERR)=0) ; kludge to check for errors
S NOW=$$NOW^XLFDT(),TODAY=$P(NOW,".",1)
I '$G(BEG) S BEG=$$X2FM($$RNGVBEG)
I '$G(END) S END=$$X2FM($$RNGVEND)+0.2359
S COUNT=0
K ^TMP("ORVSTLIST",$J)
S VAERR=0
I END>NOW D Q:VAERR ; get future encounters, past cancels/no-shows from VADPT
. S VASD("F")=BEG
. S VASD("T")=END
. S VASD("W")="123456789"
. D SDA^ORQRY01(.ERR,.ERRMSG)
. I CHECKERR,ERR K ^UTILITY("VASD",$J) S ORVISIT(1)=ERRMSG Q ;IA 10061
. S I=0 F S I=$O(^UTILITY("VASD",$J,I)) Q:'I D
. . S XI=^UTILITY("VASD",$J,I,"I"),XE=^("E")
. . S DTM=$P(XI,U),IEN=$P(XI,U,2),STI=$P(XI,U,3)
. . S LOC=$P(XE,U,2),STS=$P(XE,U,3)
. . I DTM<TODAY,(STI=""!(STI["I")!(STI="NT")) Q ; no prior kept appts
. . S ^TMP("ORVSTLIST",$J,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
. K ^UTILITY("VASD",$J)
I BEG'>NOW D ;past encounters from ACRP Toolkit - set in CALLBACK
. S BDT=BEG
. S EDT=$S(END<NOW:END,1:NOW)
. D OPEN^SDQ(.ORQUERY)
. I '$$ERRCHK^SDQUT() D INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET")
. I '$$ERRCHK^SDQUT() D PAT^SDQ(.ORQUERY,DFN,"SET")
. I '$$ERRCHK^SDQUT() D DATE^SDQ(.ORQUERY,BDT,EDT,"SET")
. I '$$ERRCHK^SDQUT() D
. . S ORLST=$NA(^TMP("ORVSTLIST",$J))
. . D SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET")
. I '$$ERRCHK^SDQUT() D ACTIVE^SDQ(.ORQUERY,"TRUE","SET")
. I '$$ERRCHK^SDQUT() D SCAN^SDQ(.ORQUERY,"FORWARD")
. D CLOSE^SDQ(.ORQUERY)
;
I '$G(SKIP) D
. N TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE ; admits
. S EARLY=$$X2FM($$RNGVBEG),DONE=0
. S TIM="" F S TIM=$O(^DGPM("ATID1",DFN,TIM)) Q:TIM'>0 D Q:DONE
. . S MOV=0 F S MOV=$O(^DGPM("ATID1",DFN,TIM,MOV)) Q:MOV'>0 D Q:DONE
. . . S X0=^DGPM(MOV,0),MTIM=$P(X0,U)
. . . I MTIM<EARLY S DONE=1 Q
. . . S XTYP=$P($G(^DG(405.1,+$P(X0,U,4),0)),U,1)
. . . S XLOC=$P($G(^DIC(42,+$P(X0,U,6),0)),U,1),HLOC=+$G(^(44))
. . . S ^TMP("ORVSTLIST",$J,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
;
S COUNT=0
S I=0 F S I=$O(^TMP("ORVSTLIST",$J,I)) Q:'I D
. S J="" F S J=$O(^TMP("ORVSTLIST",$J,I,J)) Q:J="" D
. . S K=0 F S K=$O(^TMP("ORVSTLIST",$J,I,J,K)) Q:'K D
. . . S COUNT=COUNT+1
. . . S ORVISIT(COUNT)=^TMP("ORVSTLIST",$J,I,J,K)
K ^TMP("ORVSTLIST",$J)
Q
CALLBACK(IEN,NODE0,ARRAY,STOP) ; called back from ACRP Toolkit for encounters
;
; IEN and NODE0 relate to Outpatient Encounter File
; set STOP to 1 if need to quit
;
N COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC
S DTM=+NODE0,COUNT=1
S LOC=$P(NODE0,"^",4)
S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS"))
I OOS Q ; ignore OOS locations
I $P(NODE0,"^",6) Q ; not parent encounter
S XSTAT=$P($G(^SD(409.63,+$P(NODE0,"^",12),0)),"^")
S TYPE=$S($P(NODE0,"^",8)=1:"A",1:"V")
I TYPE="V",$D(@ARRAY@(DTM,"V")) S COUNT=$O(@ARRAY@(DTM,"V","A"),-1)+1 ; same d/t
S @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT
Q
DTLVST(RPT,DFN,IEN,APPTINFO) ; return progress notes / discharge summary
N VISIT
I $P(APPTINFO,";")="A" D Q
. S VISIT=$$APPT2VST^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
. I VISIT=0 S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
. D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
I $P(APPTINFO,";")="V" D Q
. S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
. D DETNOTE^ORQQVS(.RPT,DFN,VISIT)
I $P(APPTINFO,";")="I" D Q
. S VISIT=+$$GETENC^PXAPI(DFN,$P(APPTINFO,";",2),$P(APPTINFO,";",3))
. D DETSUM^ORQQVS(.RPT,DFN,VISIT)
. K ^TMP("PXKENC",$J)
Q
X2FM(X) ; return FM date given relative date
N %DT S %DT="TS" D ^%DT
Q Y
RNGLAB(DFN) ; return days back for patient
N INPT,PAR,LOC
S INPT=0 I $L($G(^DPT(DFN,.1))) S INPT=1,LOC=^(.1)
S PAR="ORQQLR DATE RANGE "_$S(INPT:"INPT",1:"OUTPT")
Q $$GET^XPAR("ALL"_$S(INPT:"^LOC."_LOC,1:""),PAR,1,"I")
;
RNGVBEG() ; return start date for encounters
Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I")
;
RNGVEND() ; return stop date for encounters
Q $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I")
;
RANGES(REC,DFN) ; return ranges given a patient
N REC
S REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND
Q
ORWCV ; SLC/KCM - Background Cover Sheet Load; ; 3/6/08 6:34am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243,282**;Dec 17, 1997;Build 6
+2 ;
+3 ;
+4 ; DBIA 1096 Reference to ^DGPM("ATID1"
+5 ; DBIA 1894 Reference to GETENC^PXAPI
+6 ; DBIA 1895 Reference to APPT2VST^PXAPI
+7 ; DBIA 2096 Reference to ^SD(409.63
+8 ; DBIA 2437 Reference to ^DGPM(
+9 ; DBIA 2965 Reference to ^DIC(405.1
+10 ; DBIA 4011 Access ^XWB(8994)
+11 ; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT")
+12 ; DBIA 4325 References to AWCMCPR1
+13 ; DBIA 10061 Reference to ^UTILITY
+14 ; CPRS has a SACC exemption for usage of the variable $ZE
+15 ;
START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background
+1 NEW ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,SECT,BACK,X,I,ORLIST,STR,FILE,NODE,ORHTIME,ORX
+2 ; Capacity planning timing code uses ORHTIME
+3 SET ORHTIME=$HOROLOG
+4 SET LOC=$GET(LOC)
SET NODO=";"_$GET(NODO)
SET NEWREM=+$GET(NEWREM)
+5 DO GETLST^XPAR(.ORX,"SYS^PKG","ORWOR COVER RETRIEVAL NEW","Q")
+6 SET I=0
FOR
SET I=$ORDER(ORX(I))
IF 'I
QUIT
IF $DATA(^ORD(101.24,+ORX(I),0))
SET SECT(+$PIECE(^(0),"^",2))=$PIECE(ORX(I),"^",2)
+7 DO GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
+8 SET (VAL,BACK,STR,FILE)=""
+9 FOR
SET I=$ORDER(ORLIST(I))
IF 'I
QUIT
IF $DATA(^ORD(101.24,$PIECE(ORLIST(I),"^",2),0))
SET X0=^(0)
Begin DoDot:1
+10 IF $PIECE(X0,"^",8)'="C"
QUIT
+11 SET X=$PIECE(X0,"^",2)
+12 ; if in NODO, dont do section
IF NODO[(";"_X_";")
QUIT
+13 SET STR=STR_X_";"
+14 ; load section in foreground
IF '$GET(SECT(X))
SET VAL=VAL_X_";"
+15 ; load section in background
IF '$TEST
SET BACK=BACK_X_";"
SET FILE=FILE_$PIECE(ORLIST(I),"^",2)_";"
End DoDot:1
+16 IF BACK=""
QUIT
+17 SET ZTIO="ORW THREAD RESOURCE"
SET ZTRTN="BUILD^ORWCV"
SET ZTDTH=$HOROLOG
+18 SET (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))=""
+19 SET ZTDESC="CPRS GUI Background Data Retrieval"
+20 DO ^%ZTLOAD
IF '$DATA(ZTSK)
SET VAL=STR
QUIT
+21 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
+22 KILL ^XTMP(NODE)
+23 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK
+24 ; Start capacity planning timing clock - will be stopped in POLL code
+25 IF +$GET(^KMPTMP("KMPD-CPRS"))
SET ^KMPTMP("KMPDT","ORWCV",NODE)=$GET(ORHTIME)_"^^"_$GET(DUZ)_"^"_$GET(IO("CLNM"))
+26 QUIT
BUILD ; called in background by task manager, expects DFN, JobID
+1 NEW NODE,IFLE,ORFNUM,ID,ENT,RTN,INODE,PARAM1,PARAM2,DETAIL,X0,X2
+2 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
+3 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+4 ; client no longer polling
IF $GET(^XTMP(NODE,"STOP"))
KILL ^XTMP(NODE)
QUIT
+5 ; XTMP node has been purged
IF '$DATA(^XTMP(NODE,0))
QUIT
+6 LOCK +^XTMP(NODE)
+7 SET ^XTMP(NODE,"DFN")=DFN
+8 ;N $ETRAP,$ESTACK
+9 ;S $ETRAP="D ERR^ORWCV Q"
+10 IF $LENGTH($GET(FILE),";")>0
FOR IFLE=1:1:$LENGTH(FILE,";")
SET ORFNUM=$PIECE(FILE,";",IFLE)
IF '$DATA(^ORD(101.24,+ORFNUM,0))
QUIT
SET X0=^(0)
SET X2=$GET(^(2))
Begin DoDot:1
+11 SET ID=$PIECE(X0,"^",2)
SET ENT=$PIECE(X0,"^",6)
SET RTN=$PIECE(X0,"^",5)
SET PARAM1=$PIECE(X2,"^")
SET PARAM2=$PIECE(X2,"^",2)
SET INODE=$PIECE(X2,"^",5)
SET DETAIL=""
+12 ;DBIA 4011
IF $PIECE(X0,"^",18)
SET DETAIL=$PIECE($GET(^ORD(101.24,+$PIECE(X0,"^",18),0)),"^",13)
SET DETAIL=$PIECE($GET(^XWB(8994,+DETAIL,0)),"^")
+13 IF '$LENGTH(INODE)
QUIT
+14 IF '$LENGTH(ENT)
SET LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$PIECE(X0,"^")_", IFN="_+ORFNUM
DO LST2XTMP(INODE)
QUIT
+15 IF '$LENGTH(RTN)
SET LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$PIECE(X0,"^")_", IFN="_+ORFNUM
DO LST2XTMP(INODE)
QUIT
+16 IF '$LENGTH($TEXT(@(ENT_"^"_RTN)))
SET LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$PIECE(X0,"^")_", IFN="_+ORFNUM
DO LST2XTMP(INODE)
QUIT
+17 ;Special case for reminders
IF ID=50
IF $LENGTH($TEXT(STRT3^AWCMCPR1))
DO STRT3^AWCMCPR1
Begin DoDot:2
+18 IF $GET(NEWREM)
DO APPL^ORQQPXRM(.LST,DFN,LOC)
IF 1
+19 IF '$TEST
DO @(ENT_"^"_RTN_"(.LST,DFN)")
+20 DO LST2XTMP(INODE)
End DoDot:2
IF $LENGTH($TEXT(END^AWCMCPR1))
DO END^AWCMCPR1
QUIT
+21 IF $LENGTH(PARAM1)
IF $LENGTH(PARAM2)
DO @(ENT_"^"_RTN_"(.LST,DFN,PARAM1,PARAM2)")
DO LST2XTMP(INODE)
QUIT
+22 IF $LENGTH(PARAM1)
DO @(ENT_"^"_RTN_"(.LST,DFN,PARAM1)")
DO LST2XTMP(INODE)
QUIT
+23 DO @(ENT_"^"_RTN_"(.LST,DFN)")
DO LST2XTMP(INODE)
End DoDot:1
+24 SET ^XTMP(NODE,"DONE")=1
+25 IF $GET(^XTMP(NODE,"STOP"))
KILL ^XTMP(NODE)
+26 LOCK -^XTMP(NODE)
+27 QUIT
ERR ;Error trap
+1 SET $ETRAP="D UNWIND^ORWCV Q"
+2 IF $DATA(NODE)
Begin DoDot:1
+3 IF $DATA(INODE)
SET LST(0)=""
SET LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$ZERROR
DO LST2XTMP(INODE)
+4 SET ^XTMP(NODE,"DONE")=1
+5 LOCK -^XTMP(NODE)
End DoDot:1
+6 ;file error
DO @^%ZOSF("ERRTN")
+7 SET $ECODE=",UOR70 error during Cover Sheet build,"
+8 QUIT
UNWIND ;Unwind Error stack
+1 ;pop the stack
IF $ESTACK>1
QUIT
+2 ;add additional code here, if needed
+3 QUIT
LST2XTMP(ID) ; put the list in ^XTMP(NODE,ID)
+1 IF $GET(^XTMP(NODE,"STOP"))
QUIT
+2 NEW I
+3 IF $LENGTH($GET(DETAIL))
SET I=0
FOR
SET I=$ORDER(LST(I))
IF 'I
QUIT
SET $PIECE(LST(I),"^",12)=DETAIL
+4 KILL ^XTMP(NODE,ID)
MERGE ^XTMP(NODE,ID)=LST
SET ^XTMP(NODE,ID)=1
KILL LST
+5 QUIT
POLL(LST,DFN,IP,HWND) ; poll for completed cover sheet parts
+1 NEW I,ILST,ID,NODE,DONE
+2 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
SET ILST=0
SET DONE=0
+3 IF '$DATA(^XTMP(NODE,"DFN"))
QUIT
+4 IF ^XTMP(NODE,"DFN")'=DFN
SET LST(1)="~DONE=1"
QUIT
+5 IF $GET(^XTMP(NODE,"DONE"))
SET ILST=ILST+1
SET LST(ILST)="~DONE=1"
SET DONE=1
+6 FOR ID="PROB","CWAD","MEDS","RMND","LABS","VITL","VSIT"
Begin DoDot:1
+7 IF '$GET(^XTMP(NODE,ID))
QUIT
+8 SET ILST=ILST+1
SET LST(ILST)="~"_ID
+9 SET I=0
FOR
SET I=$ORDER(^XTMP(NODE,ID,I))
IF 'I
QUIT
SET ILST=ILST+1
SET LST(ILST)="i"_^(I)
+10 KILL ^XTMP(NODE,ID)
End DoDot:1
+11 ; Stop capacity planning timing clock - was started in START code
+12 IF DONE
KILL ^XTMP(NODE)
IF +$GET(^KMPTMP("KMPD-CPRS"))
SET $PIECE(^KMPTMP("KMPDT","ORWCV",NODE),"^",2)=$HOROLOG
+13 QUIT
STOP(OK,DFN,IP,HWND) ; stop cover sheet data retrieval
+1 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
SET ILST=0
SET DONE=0
+2 SET ^XTMP(NODE,"STOP")=1
SET OK=1
+3 LOCK +^XTMP(NODE)
+4 IF $GET(^XTMP(NODE,"DONE"))
KILL ^XTMP(NODE)
+5 LOCK -^XTMP(NODE)
+6 QUIT
CLEAN ; clean up ^XTMP nodes
+1 SET X="ORWCV"
+2 FOR
SET X=$ORDER(^XTMP(X))
IF $EXTRACT(X,1,5)'="ORWCV"
QUIT
WRITE !,X
KILL ^XTMP(X)
+3 QUIT
LAB(LST,DFN) ; return labs for patient
+1 IF $LENGTH($TEXT(STRT2^AWCMCPR1))
DO STRT2^AWCMCPR1
+2 DO LIST^ORQOR1(.LST,DFN,"LAB",4,"T-"_$$RNGLAB(DFN),"T","AW",1)
+3 IF $LENGTH($TEXT(END^AWCMCPR1))
DO END^AWCMCPR1
+4 QUIT
+5 ;
VST1(ORVISIT,DFN,BEG,END,SKIP) ;
+1 NEW ERR,ERRMSG
+2 ; kludge to return errors
SET ERR=0
+3 IF '$GET(DFN)
QUIT
+4 DO VST(.ORVISIT,DFN,.BEG,.END,$GET(SKIP),.ERR,.ERRMSG)
+5 IF ERR
KILL ORVISIT
SET ORVISIT(1)=ERRMSG
+6 QUIT
+7 ;
TEST ;D VST(.ZZZ,76,2950101,3050401,777,1,1)
+1 QUIT
VST(ORVISIT,DFN,BEG,END,SKIP,ERR,ERRMSG) ; return appts/admissions for patient
+1 NEW CHECKERR,VAERR,VASD,BDT,COUNT,DTM,EDT,LOC,NOW,ORQUERY,ORLST,STI,STS,TODAY,I,J,K,XI,XE,X
+2 ; kludge to check for errors
SET CHECKERR=($GET(ERR)=0)
+3 SET NOW=$$NOW^XLFDT()
SET TODAY=$PIECE(NOW,".",1)
+4 IF '$GET(BEG)
SET BEG=$$X2FM($$RNGVBEG)
+5 IF '$GET(END)
SET END=$$X2FM($$RNGVEND)+0.2359
+6 SET COUNT=0
+7 KILL ^TMP("ORVSTLIST",$JOB)
+8 SET VAERR=0
+9 ; get future encounters, past cancels/no-shows from VADPT
IF END>NOW
Begin DoDot:1
+10 SET VASD("F")=BEG
+11 SET VASD("T")=END
+12 SET VASD("W")="123456789"
+13 DO SDA^ORQRY01(.ERR,.ERRMSG)
+14 ;IA 10061
IF CHECKERR
IF ERR
KILL ^UTILITY("VASD",$JOB)
SET ORVISIT(1)=ERRMSG
QUIT
+15 SET I=0
FOR
SET I=$ORDER(^UTILITY("VASD",$JOB,I))
IF 'I
QUIT
Begin DoDot:2
+16 SET XI=^UTILITY("VASD",$JOB,I,"I")
SET XE=^("E")
+17 SET DTM=$PIECE(XI,U)
SET IEN=$PIECE(XI,U,2)
SET STI=$PIECE(XI,U,3)
+18 SET LOC=$PIECE(XE,U,2)
SET STS=$PIECE(XE,U,3)
+19 ; no prior kept appts
IF DTM<TODAY
IF (STI=""!(STI["I")!(STI="NT"))
QUIT
+20 SET ^TMP("ORVSTLIST",$JOB,DTM,"A",1)="A;"_DTM_";"_IEN_U_DTM_U_LOC_U_STS
End DoDot:2
+21 KILL ^UTILITY("VASD",$JOB)
End DoDot:1
IF VAERR
QUIT
+22 ;past encounters from ACRP Toolkit - set in CALLBACK
IF BEG'>NOW
Begin DoDot:1
+23 SET BDT=BEG
+24 SET EDT=$SELECT(END<NOW:END,1:NOW)
+25 DO OPEN^SDQ(.ORQUERY)
+26 IF '$$ERRCHK^SDQUT()
DO INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET")
+27 IF '$$ERRCHK^SDQUT()
DO PAT^SDQ(.ORQUERY,DFN,"SET")
+28 IF '$$ERRCHK^SDQUT()
DO DATE^SDQ(.ORQUERY,BDT,EDT,"SET")
+29 IF '$$ERRCHK^SDQUT()
Begin DoDot:2
+30 SET ORLST=$NAME(^TMP("ORVSTLIST",$JOB))
+31 DO SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET")
End DoDot:2
+32 IF '$$ERRCHK^SDQUT()
DO ACTIVE^SDQ(.ORQUERY,"TRUE","SET")
+33 IF '$$ERRCHK^SDQUT()
DO SCAN^SDQ(.ORQUERY,"FORWARD")
+34 DO CLOSE^SDQ(.ORQUERY)
End DoDot:1
+35 ;
+36 IF '$GET(SKIP)
Begin DoDot:1
+37 ; admits
NEW TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE
+38 SET EARLY=$$X2FM($$RNGVBEG)
SET DONE=0
+39 SET TIM=""
FOR
SET TIM=$ORDER(^DGPM("ATID1",DFN,TIM))
IF TIM'>0
QUIT
Begin DoDot:2
+40 SET MOV=0
FOR
SET MOV=$ORDER(^DGPM("ATID1",DFN,TIM,MOV))
IF MOV'>0
QUIT
Begin DoDot:3
+41 SET X0=^DGPM(MOV,0)
SET MTIM=$PIECE(X0,U)
+42 IF MTIM<EARLY
SET DONE=1
QUIT
+43 SET XTYP=$PIECE($GET(^DG(405.1,+$PIECE(X0,U,4),0)),U,1)
+44 SET XLOC=$PIECE($GET(^DIC(42,+$PIECE(X0,U,6),0)),U,1)
SET HLOC=+$GET(^(44))
+45 SET ^TMP("ORVSTLIST",$JOB,MTIM,"I",1)="I;"_MTIM_";"_HLOC_U_MTIM_U_"Inpatient Stay"_U_XLOC_U_XTYP
End DoDot:3
IF DONE
QUIT
End DoDot:2
IF DONE
QUIT
End DoDot:1
+46 ;
+47 SET COUNT=0
+48 SET I=0
FOR
SET I=$ORDER(^TMP("ORVSTLIST",$JOB,I))
IF 'I
QUIT
Begin DoDot:1
+49 SET J=""
FOR
SET J=$ORDER(^TMP("ORVSTLIST",$JOB,I,J))
IF J=""
QUIT
Begin DoDot:2
+50 SET K=0
FOR
SET K=$ORDER(^TMP("ORVSTLIST",$JOB,I,J,K))
IF 'K
QUIT
Begin DoDot:3
+51 SET COUNT=COUNT+1
+52 SET ORVISIT(COUNT)=^TMP("ORVSTLIST",$JOB,I,J,K)
End DoDot:3
End DoDot:2
End DoDot:1
+53 KILL ^TMP("ORVSTLIST",$JOB)
+54 QUIT
CALLBACK(IEN,NODE0,ARRAY,STOP) ; called back from ACRP Toolkit for encounters
+1 ;
+2 ; IEN and NODE0 relate to Outpatient Encounter File
+3 ; set STOP to 1 if need to quit
+4 ;
+5 NEW COUNT,DTM,LOC,OOS,TYPE,XSTAT,XLOC
+6 SET DTM=+NODE0
SET COUNT=1
+7 SET LOC=$PIECE(NODE0,"^",4)
+8 SET XLOC=$PIECE($GET(^SC(+LOC,0)),U)
SET OOS=$GET(^("OOS"))
+9 ; ignore OOS locations
IF OOS
QUIT
+10 ; not parent encounter
IF $PIECE(NODE0,"^",6)
QUIT
+11 SET XSTAT=$PIECE($GET(^SD(409.63,+$PIECE(NODE0,"^",12),0)),"^")
+12 SET TYPE=$SELECT($PIECE(NODE0,"^",8)=1:"A",1:"V")
+13 ; same d/t
IF TYPE="V"
IF $DATA(@ARRAY@(DTM,"V"))
SET COUNT=$ORDER(@ARRAY@(DTM,"V","A"),-1)+1
+14 SET @ARRAY@(DTM,TYPE,COUNT)=TYPE_";"_DTM_";"_LOC_U_DTM_U_XLOC_U_XSTAT
+15 QUIT
DTLVST(RPT,DFN,IEN,APPTINFO) ; return progress notes / discharge summary
+1 NEW VISIT
+2 IF $PIECE(APPTINFO,";")="A"
Begin DoDot:1
+3 SET VISIT=$$APPT2VST^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
+4 IF VISIT=0
SET VISIT=+$$GETENC^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
+5 DO DETNOTE^ORQQVS(.RPT,DFN,VISIT)
End DoDot:1
QUIT
+6 IF $PIECE(APPTINFO,";")="V"
Begin DoDot:1
+7 SET VISIT=+$$GETENC^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
+8 DO DETNOTE^ORQQVS(.RPT,DFN,VISIT)
End DoDot:1
QUIT
+9 IF $PIECE(APPTINFO,";")="I"
Begin DoDot:1
+10 SET VISIT=+$$GETENC^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
+11 DO DETSUM^ORQQVS(.RPT,DFN,VISIT)
+12 KILL ^TMP("PXKENC",$JOB)
End DoDot:1
QUIT
+13 QUIT
X2FM(X) ; return FM date given relative date
+1 NEW %DT
SET %DT="TS"
DO ^%DT
+2 QUIT Y
RNGLAB(DFN) ; return days back for patient
+1 NEW INPT,PAR,LOC
+2 SET INPT=0
IF $LENGTH($GET(^DPT(DFN,.1)))
SET INPT=1
SET LOC=^(.1)
+3 SET PAR="ORQQLR DATE RANGE "_$SELECT(INPT:"INPT",1:"OUTPT")
+4 QUIT $$GET^XPAR("ALL"_$SELECT(INPT:"^LOC."_LOC,1:""),PAR,1,"I")
+5 ;
RNGVBEG() ; return start date for encounters
+1 QUIT $$GET^XPAR("ALL","ORQQCSDR CS RANGE START",1,"I")
+2 ;
RNGVEND() ; return stop date for encounters
+1 QUIT $$GET^XPAR("ALL","ORQQCSDR CS RANGE STOP",1,"I")
+2 ;
RANGES(REC,DFN) ; return ranges given a patient
+1 NEW REC
+2 SET REC=$$RNGLAB(DFN)_U_$$RNGVBEG_U_$$RNGVEND
+3 QUIT
