- ORWCV ;SLC/KCM - Background Cover Sheet Load;03/06/20 13:00
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243,282,302,280,496,377**;Dec 17, 1997;Build 582
- ;
- ;
- ; DBIA 36 Reference to ^DIC(42
- ; DBIA 518 Reference to ^SC(
- ; 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 ^DG(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
- ;
- START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background
- N ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSK,SECT,BACK,X,I,ORLIST,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),U,2))=$P(ORX(I),U,2)
- D GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
- S (VAL,BACK,FILE)=""
- F S I=$O(ORLIST(I)) Q:'I I $D(^ORD(101.24,$P(ORLIST(I),U,2),0)) S X0=^(0) D
- . Q:$P(X0,U,8)'="C"
- . S X=$P(X0,U,2)
- . I NODO[(";"_X_";") Q ; if in NODO, dont do section
- . I '$G(SECT(X)) S VAL=VAL_X_";" ; load section in foreground
- . E S BACK=BACK_X_";",FILE=FILE_$P(ORLIST(I),U,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=VAL_BACK 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)_U_$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($G(DILOCKTM)>0:DILOCKTM,1:5)
- S ^XTMP(NODE,"DFN")=DFN
- F IFLE=1:1:$L(FILE,";") D
- . N $ETRAP,$ESTACK,CALL
- . S $ETRAP="D ERR^ORWCV"
- . S ORFNUM=$P(FILE,";",IFLE) Q:'$D(^ORD(101.24,+ORFNUM,0))
- . S X0=^ORD(101.24,+ORFNUM,0),X2=$G(^(2))
- . S ID=$P(X0,U,2),ENT=$P(X0,U,6),RTN=$P(X0,U,5),PARAM1=$P(X2,U)
- . S PARAM2=$P(X2,U,2),INODE=$P(X2,U,5),DETAIL=""
- . I $P(X0,U,18) S DETAIL=$P($G(^ORD(101.24,+$P(X0,U,18),0)),U,13),DETAIL=$P($G(^XWB(8994,+DETAIL,0)),U) ;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,U)_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
- . I '$L(RTN) S LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$P(X0,U)_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
- . I '$L($T(@(ENT_U_RTN))) S LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$P(X0,U)_", IFN="_+ORFNUM D LST2XTMP(INODE) Q
- . S CALL="(.LST,DFN"
- . I ID=50 S CALL="REM^ORWCV"_CALL_","""_ENT_U_RTN_""""
- . E S CALL=ENT_U_RTN_CALL
- . I $L(PARAM1) S CALL=CALL_",PARAM1"
- . I $L(PARAM2) S CALL=CALL_",PARAM2"
- . S CALL=CALL_")"
- . D @(CALL),LST2XTMP(INODE)
- S ^XTMP(NODE,"DONE")=1
- I $G(^XTMP(NODE,"STOP")) K ^XTMP(NODE)
- L -^XTMP(NODE)
- Q
- ERR ;Error trap
- I $D(NODE),$D(INODE) K LST S LST(0)="",LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$$EC^%ZOSV
- D @^%ZOSF("ERRTN") ;file error
- S $ECODE=""
- 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),U,12)=DETAIL
- K ^XTMP(NODE,ID) M ^XTMP(NODE,ID)=LST S ^XTMP(NODE,ID)=1 K LST
- S ^XTMP(NODE,"PANELS",ID)=""
- Q
- POLL(LST,DFN,IP,HWND,ONLYID) ; poll for completed cover sheet parts
- N ILST,ID,NODE,DONE
- I '$D(DFN)!('$D(IP))!('$D(HWND)) S LST="" Q
- 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
- I $D(ONLYID) D
- . D CHK(NODE,ONLYID,.ILST,.LST)
- . I DONE,$D(^XTMP(NODE,"PANELS")) S DONE=0
- I '$D(ONLYID) S ID="" F S ID=$O(^XTMP(NODE,ID)) Q:ID="" D
- . D CHK(NODE,ID,.ILST,.LST)
- ; 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),U,2)=$H
- Q
- CHK(NODE,ID,ILST,LST) ; check an individual panel
- N I
- 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),^XTMP(NODE,"PANELS",ID)
- 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):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
- 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
- REM(LST,DFN,OLDCALL) ; return reminders for patient
- I $L($T(STRT3^AWCMCPR1))>0 D STRT3^AWCMCPR1
- I $G(NEWREM) D APPL^ORQQPXRM(.LST,DFN,LOC)
- I '$G(NEWREM) D @(OLDCALL_"(.LST,DFN)")
- I $L($T(END^AWCMCPR1))>0 D 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 COVER^SDRROR
- . 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,U,4)
- S XLOC=$P($G(^SC(+LOC,0)),U),OOS=$G(^("OOS"))
- I OOS Q ; ignore OOS locations
- I $P(NODE0,U,6) Q ; not parent encounter
- S XSTAT=$P($G(^SD(409.63,+$P(NODE0,U,12),0)),U)
- S TYPE=$S($P(NODE0,U,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)
- . N X1,X2 S (X1,X2)=0 F S X1=$O(RPT(X1)) Q:X1'>0 S X2=X1 ;get the last entry in the RPT list
- . I X2'>0 S X2=1
- . N XSD,XSDDT,SDURL
- . S XSD=$P(APPTINFO,";",3),XSDDT=$P(APPTINFO,";",2) ;look up the entry in the appointment multiple and get the url
- . Q:'$D(^SC($G(XSD),0)) ; No clinic
- . Q:'$D(^SC($G(XSD),"S",XSDDT)) ; No appointment at that time
- . K XX1 S XX1=0 F S XX1=$O(^SC(XSD,"S",XSDDT,1,XX1)) Q:$G(XX1)'>0 D
- . . Q:$P(^SC(XSD,"S",XSDDT,1,XX1,0),"^",1)'=DFN
- . . Q:$G(SDURL)'=""
- . . S SDURL=$G(^SC(XSD,"S",XSDDT,1,XX1,"URL"))
- . S RPT(X2)=$G(SDURL)
- . K XSD,XSDDT,SDURL
- 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)
- I $P(APPTINFO,";")="R" D RCDTL^SDRROR
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWCV 11153 printed Jan 18, 2025@03:36:16 Page 2
- ORWCV ;SLC/KCM - Background Cover Sheet Load;03/06/20 13:00
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,132,209,214,195,215,260,243,282,302,280,496,377**;Dec 17, 1997;Build 582
- +2 ;
- +3 ;
- +4 ; DBIA 36 Reference to ^DIC(42
- +5 ; DBIA 518 Reference to ^SC(
- +6 ; DBIA 1096 Reference to ^DGPM("ATID1"
- +7 ; DBIA 1894 Reference to GETENC^PXAPI
- +8 ; DBIA 1895 Reference to APPT2VST^PXAPI
- +9 ; DBIA 2096 Reference to ^SD(409.63
- +10 ; DBIA 2437 Reference to ^DGPM(
- +11 ; DBIA 2965 Reference to ^DG(405.1
- +12 ; DBIA 4011 Access ^XWB(8994)
- +13 ; DBIA 4313 Direct R/W permission to capacity mgmt global ^KMPTMP("KMPDT")
- +14 ; DBIA 4325 References to AWCMCPR1
- +15 ; DBIA 10061 Reference to ^UTILITY
- +16 ;
- START(VAL,DFN,IP,HWND,LOC,NODO,NEWREM) ; start cover sheet build in background
- +1 NEW ZTIO,ZTRTN,ZTDTH,ZTSAVE,ZTDESC,ZTSK,SECT,BACK,X,I,ORLIST,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),U,2))=$PIECE(ORX(I),U,2)
- +7 DO GETLST^XPAR(.ORLIST,"ALL","ORWCV1 COVERSHEET LIST")
- +8 SET (VAL,BACK,FILE)=""
- +9 FOR
- SET I=$ORDER(ORLIST(I))
- if 'I
- QUIT
- IF $DATA(^ORD(101.24,$PIECE(ORLIST(I),U,2),0))
- SET X0=^(0)
- Begin DoDot:1
- +10 if $PIECE(X0,U,8)'="C"
- QUIT
- +11 SET X=$PIECE(X0,U,2)
- +12 ; if in NODO, dont do section
- IF NODO[(";"_X_";")
- QUIT
- +13 ; load section in foreground
- IF '$GET(SECT(X))
- SET VAL=VAL_X_";"
- +14 ; load section in background
- IF '$TEST
- SET BACK=BACK_X_";"
- SET FILE=FILE_$PIECE(ORLIST(I),U,2)_";"
- End DoDot:1
- +15 if BACK=""
- QUIT
- +16 SET ZTIO="ORW THREAD RESOURCE"
- SET ZTRTN="BUILD^ORWCV"
- SET ZTDTH=$HOROLOG
- +17 SET (ZTSAVE("DFN"),ZTSAVE("IP"),ZTSAVE("HWND"),ZTSAVE("NEWREM"),ZTSAVE("LOC"),ZTSAVE("BACK"),ZTSAVE("FILE"))=""
- +18 SET ZTDESC="CPRS GUI Background Data Retrieval"
- +19 DO ^%ZTLOAD
- IF '$DATA(ZTSK)
- SET VAL=VAL_BACK
- QUIT
- +20 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
- +21 KILL ^XTMP(NODE)
- +22 SET ^XTMP(NODE,0)=$$FMADD^XLFDT(DT,1)_U_DT_U_"Background CPRS "_ZTSK
- +23 ; Start capacity planning timing clock - will be stopped in POLL code
- +24 IF +$GET(^KMPTMP("KMPD-CPRS"))
- SET ^KMPTMP("KMPDT","ORWCV",NODE)=$GET(ORHTIME)_"^^"_$GET(DUZ)_U_$GET(IO("CLNM"))
- +25 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):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
- +7 SET ^XTMP(NODE,"DFN")=DFN
- +8 FOR IFLE=1:1:$LENGTH(FILE,";")
- Begin DoDot:1
- +9 NEW $ETRAP,$ESTACK,CALL
- +10 SET $ETRAP="D ERR^ORWCV"
- +11 SET ORFNUM=$PIECE(FILE,";",IFLE)
- if '$DATA(^ORD(101.24,+ORFNUM,0))
- QUIT
- +12 SET X0=^ORD(101.24,+ORFNUM,0)
- SET X2=$GET(^(2))
- +13 SET ID=$PIECE(X0,U,2)
- SET ENT=$PIECE(X0,U,6)
- SET RTN=$PIECE(X0,U,5)
- SET PARAM1=$PIECE(X2,U)
- +14 SET PARAM2=$PIECE(X2,U,2)
- SET INODE=$PIECE(X2,U,5)
- SET DETAIL=""
- +15 ;DBIA 4011
- IF $PIECE(X0,U,18)
- SET DETAIL=$PIECE($GET(^ORD(101.24,+$PIECE(X0,U,18),0)),U,13)
- SET DETAIL=$PIECE($GET(^XWB(8994,+DETAIL,0)),U)
- +16 IF '$LENGTH(INODE)
- QUIT
- +17 IF '$LENGTH(ENT)
- SET LST(IFLE)="0^ERROR: Missing ENTRY POINT field in file 101.24 for "_$PIECE(X0,U)_", IFN="_+ORFNUM
- DO LST2XTMP(INODE)
- QUIT
- +18 IF '$LENGTH(RTN)
- SET LST(IFLE)="0^ERROR: Missing ROUTINE field in file 101.24 for "_$PIECE(X0,U)_", IFN="_+ORFNUM
- DO LST2XTMP(INODE)
- QUIT
- +19 IF '$LENGTH($TEXT(@(ENT_U_RTN)))
- SET LST(IFLE)="0^ERROR: "_ENT_"~"_RTN_" does not exist. See file 101.24 entry: "_$PIECE(X0,U)_", IFN="_+ORFNUM
- DO LST2XTMP(INODE)
- QUIT
- +20 SET CALL="(.LST,DFN"
- +21 IF ID=50
- SET CALL="REM^ORWCV"_CALL_","""_ENT_U_RTN_""""
- +22 IF '$TEST
- SET CALL=ENT_U_RTN_CALL
- +23 IF $LENGTH(PARAM1)
- SET CALL=CALL_",PARAM1"
- +24 IF $LENGTH(PARAM2)
- SET CALL=CALL_",PARAM2"
- +25 SET CALL=CALL_")"
- +26 DO @(CALL)
- DO LST2XTMP(INODE)
- End DoDot:1
- +27 SET ^XTMP(NODE,"DONE")=1
- +28 IF $GET(^XTMP(NODE,"STOP"))
- KILL ^XTMP(NODE)
- +29 LOCK -^XTMP(NODE)
- +30 QUIT
- ERR ;Error trap
- +1 IF $DATA(NODE)
- IF $DATA(INODE)
- KILL LST
- SET LST(0)=""
- SET LST(1)="0^ERROR DURING COVER SHEET BUILD:"_$$EC^%ZOSV
- +2 ;file error
- DO @^%ZOSF("ERRTN")
- +3 SET $ECODE=""
- +4 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),U,12)=DETAIL
- +4 KILL ^XTMP(NODE,ID)
- MERGE ^XTMP(NODE,ID)=LST
- SET ^XTMP(NODE,ID)=1
- KILL LST
- +5 SET ^XTMP(NODE,"PANELS",ID)=""
- +6 QUIT
- POLL(LST,DFN,IP,HWND,ONLYID) ; poll for completed cover sheet parts
- +1 NEW ILST,ID,NODE,DONE
- +2 IF '$DATA(DFN)!('$DATA(IP))!('$DATA(HWND))
- SET LST=""
- QUIT
- +3 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
- SET ILST=0
- SET DONE=0
- +4 IF '$DATA(^XTMP(NODE,"DFN"))
- QUIT
- +5 IF ^XTMP(NODE,"DFN")'=DFN
- SET LST(1)="~DONE=1"
- QUIT
- +6 IF $GET(^XTMP(NODE,"DONE"))
- SET ILST=ILST+1
- SET LST(ILST)="~DONE=1"
- SET DONE=1
- +7 IF $DATA(ONLYID)
- Begin DoDot:1
- +8 DO CHK(NODE,ONLYID,.ILST,.LST)
- +9 IF DONE
- IF $DATA(^XTMP(NODE,"PANELS"))
- SET DONE=0
- End DoDot:1
- +10 IF '$DATA(ONLYID)
- SET ID=""
- FOR
- SET ID=$ORDER(^XTMP(NODE,ID))
- if ID=""
- QUIT
- Begin DoDot:1
- +11 DO CHK(NODE,ID,.ILST,.LST)
- End DoDot:1
- +12 ; Stop capacity planning timing clock - was started in START code
- +13 IF DONE
- KILL ^XTMP(NODE)
- IF +$GET(^KMPTMP("KMPD-CPRS"))
- SET $PIECE(^KMPTMP("KMPDT","ORWCV",NODE),U,2)=$HOROLOG
- +14 QUIT
- CHK(NODE,ID,ILST,LST) ; check an individual panel
- +1 NEW I
- +2 IF '$GET(^XTMP(NODE,ID))
- QUIT
- +3 SET ILST=ILST+1
- SET LST(ILST)="~"_ID
- +4 SET I=0
- FOR
- SET I=$ORDER(^XTMP(NODE,ID,I))
- if 'I
- QUIT
- SET ILST=ILST+1
- SET LST(ILST)="i"_^(I)
- +5 KILL ^XTMP(NODE,ID),^XTMP(NODE,"PANELS",ID)
- +6 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):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
- +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
- REM(LST,DFN,OLDCALL) ; return reminders for patient
- +1 IF $LENGTH($TEXT(STRT3^AWCMCPR1))>0
- DO STRT3^AWCMCPR1
- +2 IF $GET(NEWREM)
- DO APPL^ORQQPXRM(.LST,DFN,LOC)
- +3 IF '$GET(NEWREM)
- DO @(OLDCALL_"(.LST,DFN)")
- +4 IF $LENGTH($TEXT(END^AWCMCPR1))>0
- DO END^AWCMCPR1
- +5 QUIT
- 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 COVER^SDRROR
- +26 DO OPEN^SDQ(.ORQUERY)
- +27 IF '$$ERRCHK^SDQUT()
- DO INDEX^SDQ(.ORQUERY,"PATIENT/DATE","SET")
- +28 IF '$$ERRCHK^SDQUT()
- DO PAT^SDQ(.ORQUERY,DFN,"SET")
- +29 IF '$$ERRCHK^SDQUT()
- DO DATE^SDQ(.ORQUERY,BDT,EDT,"SET")
- +30 IF '$$ERRCHK^SDQUT()
- Begin DoDot:2
- +31 SET ORLST=$NAME(^TMP("ORVSTLIST",$JOB))
- +32 DO SCANCB^SDQ(.ORQUERY,"D CALLBACK^ORWCV(Y,Y0,.ORLST,.ORSTOP)","SET")
- End DoDot:2
- +33 IF '$$ERRCHK^SDQUT()
- DO ACTIVE^SDQ(.ORQUERY,"TRUE","SET")
- +34 IF '$$ERRCHK^SDQUT()
- DO SCAN^SDQ(.ORQUERY,"FORWARD")
- +35 DO CLOSE^SDQ(.ORQUERY)
- End DoDot:1
- +36 ;
- +37 IF '$GET(SKIP)
- Begin DoDot:1
- +38 ; admits
- NEW TIM,MOV,X0,Y,MTIM,XTYP,XLOC,HLOC,EARLY,DONE
- +39 SET EARLY=$$X2FM($$RNGVBEG)
- SET DONE=0
- +40 SET TIM=""
- FOR
- SET TIM=$ORDER(^DGPM("ATID1",DFN,TIM))
- if TIM'>0
- QUIT
- Begin DoDot:2
- +41 SET MOV=0
- FOR
- SET MOV=$ORDER(^DGPM("ATID1",DFN,TIM,MOV))
- if MOV'>0
- QUIT
- Begin DoDot:3
- +42 SET X0=^DGPM(MOV,0)
- SET MTIM=$PIECE(X0,U)
- +43 IF MTIM<EARLY
- SET DONE=1
- QUIT
- +44 SET XTYP=$PIECE($GET(^DG(405.1,+$PIECE(X0,U,4),0)),U,1)
- +45 SET XLOC=$PIECE($GET(^DIC(42,+$PIECE(X0,U,6),0)),U,1)
- SET HLOC=+$GET(^(44))
- +46 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
- +47 ;
- +48 SET COUNT=0
- +49 SET I=0
- FOR
- SET I=$ORDER(^TMP("ORVSTLIST",$JOB,I))
- if 'I
- QUIT
- Begin DoDot:1
- +50 SET J=""
- FOR
- SET J=$ORDER(^TMP("ORVSTLIST",$JOB,I,J))
- if J=""
- QUIT
- Begin DoDot:2
- +51 SET K=0
- FOR
- SET K=$ORDER(^TMP("ORVSTLIST",$JOB,I,J,K))
- if 'K
- QUIT
- Begin DoDot:3
- +52 SET COUNT=COUNT+1
- +53 SET ORVISIT(COUNT)=^TMP("ORVSTLIST",$JOB,I,J,K)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +54 KILL ^TMP("ORVSTLIST",$JOB)
- +55 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,U,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,U,6)
- QUIT
- +11 SET XSTAT=$PIECE($GET(^SD(409.63,+$PIECE(NODE0,U,12),0)),U)
- +12 SET TYPE=$SELECT($PIECE(NODE0,U,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)
- +6 ;get the last entry in the RPT list
- NEW X1,X2
- SET (X1,X2)=0
- FOR
- SET X1=$ORDER(RPT(X1))
- if X1'>0
- QUIT
- SET X2=X1
- +7 IF X2'>0
- SET X2=1
- +8 NEW XSD,XSDDT,SDURL
- +9 ;look up the entry in the appointment multiple and get the url
- SET XSD=$PIECE(APPTINFO,";",3)
- SET XSDDT=$PIECE(APPTINFO,";",2)
- +10 ; No clinic
- if '$DATA(^SC($GET(XSD),0))
- QUIT
- +11 ; No appointment at that time
- if '$DATA(^SC($GET(XSD),"S",XSDDT))
- QUIT
- +12 KILL XX1
- SET XX1=0
- FOR
- SET XX1=$ORDER(^SC(XSD,"S",XSDDT,1,XX1))
- if $GET(XX1)'>0
- QUIT
- Begin DoDot:2
- +13 if $PIECE(^SC(XSD,"S",XSDDT,1,XX1,0),"^",1)'=DFN
- QUIT
- +14 if $GET(SDURL)'=""
- QUIT
- +15 SET SDURL=$GET(^SC(XSD,"S",XSDDT,1,XX1,"URL"))
- End DoDot:2
- +16 SET RPT(X2)=$GET(SDURL)
- +17 KILL XSD,XSDDT,SDURL
- End DoDot:1
- QUIT
- +18 IF $PIECE(APPTINFO,";")="V"
- Begin DoDot:1
- +19 SET VISIT=+$$GETENC^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
- +20 DO DETNOTE^ORQQVS(.RPT,DFN,VISIT)
- End DoDot:1
- QUIT
- +21 IF $PIECE(APPTINFO,";")="I"
- Begin DoDot:1
- +22 SET VISIT=+$$GETENC^PXAPI(DFN,$PIECE(APPTINFO,";",2),$PIECE(APPTINFO,";",3))
- +23 DO DETSUM^ORQQVS(.RPT,DFN,VISIT)
- +24 KILL ^TMP("PXKENC",$JOB)
- End DoDot:1
- QUIT
- +25 IF $PIECE(APPTINFO,";")="R"
- DO RCDTL^SDRROR
- +26 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