- ORWDX2 ;SLC/JM,AGP - Order dialog utilities ;Feb 22, 2024@11:19
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,280,331,405,588,601**;Dec 17, 1997;Build 1
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ;Reference to $$DOSE^PSSORUTE supported by IA #4555
- ;Reference to ^DIC(9.4 supported by IA #2058
- ;Reference to ^DPT( supported by IA #10035
- ;Reference to ^XMD supported by IA #10070
- ;Reference to $$PATCH^XPDUTL supported by IA #10141
- ;
- ;
- Q
- ;
- NXT() ; -- Gets index in array
- S ILST=ILST+1
- Q ILST
- ;
- EXTVAL(IVAL,DLG) ; External value given a dlg ptr
- N ORDIALOG
- S ORDIALOG(DLG,0)=$P($G(^ORD(101.41,DLG,1)),U,1,2)
- S ORDIALOG(DLG,1)=IVAL
- I $E(ORDIALOG(DLG,0))="R",(+IVAL'=IVAL) Q IVAL ; free text date/time
- Q $$EXT^ORCD(DLG,1) ; all others
- ;
- XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
- N CHKDOSE,DOSE,INSTR,X
- S (ILST,I)=0,CHKDOSE=$$CHKDOSES
- F S I=$O(@ROOT@(I)) Q:I'>0 D
- . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
- . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
- . I '$L(ID) S ID="ID"_DLG
- . S VAL=$G(@ROOT@(I,1))
- . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE" S ID="ADDITIVE"
- . ;I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy ;DJE/VM *331 - removed, not working consistently
- . S LST($$NXT)="~"_DLG_U_INST_U_ID
- . I $L(VAL) D
- .. S LST($$NXT)="i"_VAL,LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
- .. I CHKDOSE D DOSEINFO
- . I $D(@ROOT@(I,2))>1 D
- .. I $E(RSPID)?1U,'$G(TRANS),ID="COMMENT",'$$DRAFT(RSPID) D FORMID^ORWDX(.X,+$E(RSPID,2,99)) Q:X=140
- .. S J=0 F S J=$O(@ROOT@(I,2,J)) Q:J'>0 D
- ... S LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
- I $G(ORADDTITRRESP) D TITR(.LST,.ILST)
- I CHKDOSE D FIXDOSES
- I ROOT["^OR(100," D
- . N ORIFN,OVRIDE,REMCOM,RET
- . S ORIFN=$P(ROOT,",",2) Q:+ORIFN<1
- . I "^14^13^11^10^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS",.RET)
- . I "^14^13^11^10^"'[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D GETOC3^OROCAPI1(ORIFN,"SIGNATURE_CPRS",.RET)
- . Q:'$D(RET)
- . S (OVRIDE,REMCOM)=""
- . N IEN S IEN=0 F S IEN=$O(RET(ORIFN,IEN)) Q:'IEN D Q:((OVRIDE'="")&(REMCOM'=""))
- .. I OVRIDE="" S OVRIDE=$G(^ORD(100.05,IEN,3,1,0))
- .. N X S X=0 F S X=$O(^ORD(100.05,IEN,4,X)) Q:+X=0 D Q:REMCOM'=""
- ... I REMCOM="" S REMCOM=$G(^ORD(100.05,IEN,4,X,4))
- . I OVRIDE'="" D
- .. S LST($$NXT)="~^^OVERRIDE"
- .. S LST($$NXT)="t"_OVRIDE
- . I REMCOM'="" D
- .. S LST($$NXT)="~^^ORREMCOMMENT"
- .. S LST($$NXT)="t"_REMCOM
- I $E(ROOT,1,15)="^TMP(""ORWTITR""," D Q
- . K ^TMP("ORWTITR",$J)
- I $E(ROOT,1,4)="^TMP" K ^TMP("ORWDXMQ",$J)
- Q
- ;
- DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
- N IEN,STS,ES
- I $E(ID)?1U,$E(ID)'="X" Q 0
- S IEN=$S(ID:+ID,1:+$E(ID,2,99))
- S STS=$P($G(^OR(100,IEN,3)),U,3),ES=$P($G(^(8,1,0)),U,4)
- I STS=5 Q 1
- I STS=11 Q 1
- I STS=10,ES=2 Q 1
- Q 0
- ;
- TITR(LST,ILST) ; Add titration response (when changing old titration order)
- S LST($$NXT)="~"_$$PTR^ORWDXM1("TITRATION")_"^1^TITR"
- S LST($$NXT)="i1"
- S LST($$NXT)="eYES"
- Q
- ;
- CHKDOSES() ; Returns true if doses may need to be modified
- Q $$PATCH^XPDUTL("PSS*1.0*78")&($T(DOSE^PSSORUTE)'="")
- ;
- DOSEINFO ; Collect pointers to dose information
- I ID="INSTR" S INSTR(INST)=ILST-1
- I ID="DOSE",+VAL>0 S DOSE(INST)=ILST-1 ; +VAL filters out local dosages
- Q
- ;
- FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
- N CODE,OLDDOSE,IDX,NEWDOSE,IIDX
- S IIDX=0
- F S IIDX=$O(INSTR(IIDX)) Q:'+IIDX D
- . I +$G(INSTR(IIDX))>0,+$G(DOSE(IIDX))>0 D
- .. S OLDDOSE=$E(LST(INSTR(IIDX)),2,999)
- .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
- .. I OLDDOSE'=NEWDOSE D
- ... F IDX=0:1:1 D
- .... S CODE=$E(LST(INSTR(IIDX)+IDX),1)
- .... S LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
- .. S OLDDOSE=$P(LST(DOSE(IIDX)),"&",5)
- .. S NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
- .. I OLDDOSE'=NEWDOSE D
- ... F IDX=0:1:1 D
- .... S $P(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
- Q
- ;
- DCREASON(LST) ; Return a list of DC reasons
- N ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
- S ILST=1,LST(ILST)="~DCReason"
- S IEN=0 F S IEN=$O(^ORD(100.03,IEN)) Q:'IEN S X=^(IEN,0) D
- . I $P(X,U,4) Q ; inactive
- . I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q ; not OR pkg
- . I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q ; nature=auto
- . I $P(X,U)="EHRM TRANSITIONED UTILITY" Q
- . I $P(X,U)="EHRM TRANSITIONED",'$$ONEHR^ORACCESS() Q
- . S ARRAY($P(X,U))="i"_IEN_U_$P(X,U)
- D GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
- ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
- F CNT=1:1:SEQARR D
- . S IEN=$P(SEQARR(CNT),U,2),NAME=$P(^ORD(100.03,IEN,0),U)
- . S ILST=ILST+1,LST(ILST)="i"_IEN_U_NAME
- . I $D(ARRAY(NAME))>0 K ARRAY(NAME)
- I $D(ARRAY)'>0 Q
- S NAME="" F S NAME=$O(ARRAY(NAME)) Q:NAME="" D
- .S ILST=ILST+1,LST(ILST)=ARRAY(NAME)
- Q
- SM(ERROR) ; Send message to Radiology users
- K XMY N XMDUZ,XMSUB,XMTEXT,OR0,ORIFN,DFN,OIP,OI,ORERR,MG
- S XMDUZ="CPRS,ORDERS",MG=$$GET^XPAR("SYS","OR RADIOLOGY ISSUES") I MG="" Q
- S XMY("G."_MG)="",XMSUB="CPRS Order Error on Radiology Order"
- S XMTEXT="ORERR(",ORIFN=+ERROR
- S OR0=$G(^OR(100,ORIFN,0)),DFN=+$P(OR0,"^",2),OIP=$O(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0)),OI=$G(^OR(100,ORIFN,4.5,OIP,1))
- S ORERR(1,0)="Patient: "_$P($G(^DPT(DFN,0)),"^")
- S ORERR(2,0)="CPRS Order Number: "_ORIFN
- S ORERR(3,0)="CPRS Orderable Item: "_OI_" - "_$P($G(^ORD(101.43,OI,0)),"^")
- S ORERR(4,0)=" "
- S ORERR(5,0)="Error from Radiology: "_$P(ERROR,"^",4)
- D ^XMD
- Q
- CHKLABDIV(ORDITEM,ORXREF) ; Compare user's signed in division to lab test
- ; division(s)
- I "^S.LAB^S.AP^"'[(U_ORXREF_U) Q 1
- I '+$G(DUZ(2)) Q 1
- N ORTESTIEN
- S ORTESTIEN=$P($P($G(^ORD(101.43,ORDITEM,0)),U,2),";",1)
- I '+ORTESTIEN Q 1
- I +$O(^LAB(60,ORTESTIEN,8,0))=0 Q 1
- N ORLABOK,ORINSTTYPES,ORDIV,ORDIVS,OREXIST
- ;OUTPATIENT CLINIC SHOULD SHOW OUTPATIENT CLINIC'S AND PARENT FACILITY'S TESTS
- S ORINSTTYPES("CBOC")="",ORINSTTYPES("OCMC")="",ORINSTTYPES("OCS")=""
- S ORINSTTYPES("OPC")="",ORINSTTYPES("RO-OC")=""
- S ORDIVS=1,ORDIVS(1)=DUZ(2)_U_$$NNT^XUAF4(DUZ(2))
- I $D(ORINSTTYPES($P(ORDIVS(1),U,4)))=1 D
- .S ORDIV=+$$PRNT^XUAF4($P(ORDIVS(ORDIVS),U,3))
- .S:ORDIV>0 ORDIVS=2,ORDIVS(2)=ORDIV_U_$$NNT^XUAF4(ORDIV)
- S ORLABOK=1
- F ORDIV=1:1:ORDIVS D Q:OREXIST
- . S OREXIST=$D(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV)))
- . S ORLABOK=(OREXIST>9)
- . I 'ORLABOK Q
- . S ORLABOK=($P($G(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV),0)),U,3)'=1)
- Q ORLABOK
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDX2 6488 printed Jan 18, 2025@03:37:01 Page 2
- ORWDX2 ;SLC/JM,AGP - Order dialog utilities ;Feb 22, 2024@11:19
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,280,331,405,588,601**;Dec 17, 1997;Build 1
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ;Reference to $$DOSE^PSSORUTE supported by IA #4555
- +5 ;Reference to ^DIC(9.4 supported by IA #2058
- +6 ;Reference to ^DPT( supported by IA #10035
- +7 ;Reference to ^XMD supported by IA #10070
- +8 ;Reference to $$PATCH^XPDUTL supported by IA #10141
- +9 ;
- +10 ;
- +11 QUIT
- +12 ;
- NXT() ; -- Gets index in array
- +1 SET ILST=ILST+1
- +2 QUIT ILST
- +3 ;
- EXTVAL(IVAL,DLG) ; External value given a dlg ptr
- +1 NEW ORDIALOG
- +2 SET ORDIALOG(DLG,0)=$PIECE($GET(^ORD(101.41,DLG,1)),U,1,2)
- +3 SET ORDIALOG(DLG,1)=IVAL
- +4 ; free text date/time
- IF $EXTRACT(ORDIALOG(DLG,0))="R"
- IF (+IVAL'=IVAL)
- QUIT IVAL
- +5 ; all others
- QUIT $$EXT^ORCD(DLG,1)
- +6 ;
- XROOT ; Part of LOADRSP^ORWDX - moved here because of routine size
- +1 NEW CHKDOSE,DOSE,INSTR,X
- +2 SET (ILST,I)=0
- SET CHKDOSE=$$CHKDOSES
- +3 FOR
- SET I=$ORDER(@ROOT@(I))
- if I'>0
- QUIT
- Begin DoDot:1
- +4 SET DLG=$PIECE(@ROOT@(I,0),U,2)
- SET INST=$PIECE(^(0),U,3)
- +5 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
- +6 IF '$LENGTH(ID)
- SET ID="ID"_DLG
- +7 SET VAL=$GET(@ROOT@(I,1))
- +8 IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE"
- SET ID="ADDITIVE"
- +9 ;I $E(RSPID)="C",(ID="START"),VAL Q ; skip literal start time on copy ;DJE/VM *331 - removed, not working consistently
- +10 SET LST($$NXT)="~"_DLG_U_INST_U_ID
- +11 IF $LENGTH(VAL)
- Begin DoDot:2
- +12 SET LST($$NXT)="i"_VAL
- SET LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
- +13 IF CHKDOSE
- DO DOSEINFO
- End DoDot:2
- +14 IF $DATA(@ROOT@(I,2))>1
- Begin DoDot:2
- +15 IF $EXTRACT(RSPID)?1U
- IF '$GET(TRANS)
- IF ID="COMMENT"
- IF '$$DRAFT(RSPID)
- DO FORMID^ORWDX(.X,+$EXTRACT(RSPID,2,99))
- if X=140
- QUIT
- +16 SET J=0
- FOR
- SET J=$ORDER(@ROOT@(I,2,J))
- if J'>0
- QUIT
- Begin DoDot:3
- +17 SET LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +18 IF $GET(ORADDTITRRESP)
- DO TITR(.LST,.ILST)
- +19 IF CHKDOSE
- DO FIXDOSES
- +20 IF ROOT["^OR(100,"
- Begin DoDot:1
- +21 NEW ORIFN,OVRIDE,REMCOM,RET
- +22 SET ORIFN=$PIECE(ROOT,",",2)
- if +ORIFN<1
- QUIT
- +23 IF "^14^13^11^10^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
- DO GETOC3^OROCAPI1(ORIFN,"ACCEPTANCE_CPRS",.RET)
- +24 IF "^14^13^11^10^"'[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
- DO GETOC3^OROCAPI1(ORIFN,"SIGNATURE_CPRS",.RET)
- +25 if '$DATA(RET)
- QUIT
- +26 SET (OVRIDE,REMCOM)=""
- +27 NEW IEN
- SET IEN=0
- FOR
- SET IEN=$ORDER(RET(ORIFN,IEN))
- if 'IEN
- QUIT
- Begin DoDot:2
- +28 IF OVRIDE=""
- SET OVRIDE=$GET(^ORD(100.05,IEN,3,1,0))
- +29 NEW X
- SET X=0
- FOR
- SET X=$ORDER(^ORD(100.05,IEN,4,X))
- if +X=0
- QUIT
- Begin DoDot:3
- +30 IF REMCOM=""
- SET REMCOM=$GET(^ORD(100.05,IEN,4,X,4))
- End DoDot:3
- if REMCOM'=""
- QUIT
- End DoDot:2
- if ((OVRIDE'="")&(REMCOM'=""))
- QUIT
- +31 IF OVRIDE'=""
- Begin DoDot:2
- +32 SET LST($$NXT)="~^^OVERRIDE"
- +33 SET LST($$NXT)="t"_OVRIDE
- End DoDot:2
- +34 IF REMCOM'=""
- Begin DoDot:2
- +35 SET LST($$NXT)="~^^ORREMCOMMENT"
- +36 SET LST($$NXT)="t"_REMCOM
- End DoDot:2
- End DoDot:1
- +37 IF $EXTRACT(ROOT,1,15)="^TMP(""ORWTITR"","
- Begin DoDot:1
- +38 KILL ^TMP("ORWTITR",$JOB)
- End DoDot:1
- QUIT
- +39 IF $EXTRACT(ROOT,1,4)="^TMP"
- KILL ^TMP("ORWDXMQ",$JOB)
- +40 QUIT
- +41 ;
- DRAFT(ID) ; -- Return 1 or 0 if editing an unsigned/unreleased or pending order
- +1 NEW IEN,STS,ES
- +2 IF $EXTRACT(ID)?1U
- IF $EXTRACT(ID)'="X"
- QUIT 0
- +3 SET IEN=$SELECT(ID:+ID,1:+$EXTRACT(ID,2,99))
- +4 SET STS=$PIECE($GET(^OR(100,IEN,3)),U,3)
- SET ES=$PIECE($GET(^(8,1,0)),U,4)
- +5 IF STS=5
- QUIT 1
- +6 IF STS=11
- QUIT 1
- +7 IF STS=10
- IF ES=2
- QUIT 1
- +8 QUIT 0
- +9 ;
- TITR(LST,ILST) ; Add titration response (when changing old titration order)
- +1 SET LST($$NXT)="~"_$$PTR^ORWDXM1("TITRATION")_"^1^TITR"
- +2 SET LST($$NXT)="i1"
- +3 SET LST($$NXT)="eYES"
- +4 QUIT
- +5 ;
- CHKDOSES() ; Returns true if doses may need to be modified
- +1 QUIT $$PATCH^XPDUTL("PSS*1.0*78")&($TEXT(DOSE^PSSORUTE)'="")
- +2 ;
- DOSEINFO ; Collect pointers to dose information
- +1 IF ID="INSTR"
- SET INSTR(INST)=ILST-1
- +2 ; +VAL filters out local dosages
- IF ID="DOSE"
- IF +VAL>0
- SET DOSE(INST)=ILST-1
- +3 QUIT
- +4 ;
- FIXDOSES ; Update doses for those saved before PSS*1*78 was installed
- +1 NEW CODE,OLDDOSE,IDX,NEWDOSE,IIDX
- +2 SET IIDX=0
- +3 FOR
- SET IIDX=$ORDER(INSTR(IIDX))
- if '+IIDX
- QUIT
- Begin DoDot:1
- +4 IF +$GET(INSTR(IIDX))>0
- IF +$GET(DOSE(IIDX))>0
- Begin DoDot:2
- +5 SET OLDDOSE=$EXTRACT(LST(INSTR(IIDX)),2,999)
- +6 SET NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
- +7 IF OLDDOSE'=NEWDOSE
- Begin DoDot:3
- +8 FOR IDX=0:1:1
- Begin DoDot:4
- +9 SET CODE=$EXTRACT(LST(INSTR(IIDX)+IDX),1)
- +10 SET LST(INSTR(IIDX)+IDX)=CODE_NEWDOSE
- End DoDot:4
- End DoDot:3
- +11 SET OLDDOSE=$PIECE(LST(DOSE(IIDX)),"&",5)
- +12 SET NEWDOSE=$$DOSE^PSSORUTE(OLDDOSE)
- +13 IF OLDDOSE'=NEWDOSE
- Begin DoDot:3
- +14 FOR IDX=0:1:1
- Begin DoDot:4
- +15 SET $PIECE(LST(DOSE(IIDX)+IDX),"&",5)=NEWDOSE
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;
- DCREASON(LST) ; Return a list of DC reasons
- +1 NEW ARRAY,CNT,ERROR,IEN,ILST,NAME,SEQARR,X
- +2 SET ILST=1
- SET LST(ILST)="~DCReason"
- +3 SET IEN=0
- FOR
- SET IEN=$ORDER(^ORD(100.03,IEN))
- if 'IEN
- QUIT
- SET X=^(IEN,0)
- Begin DoDot:1
- +4 ; inactive
- IF $PIECE(X,U,4)
- QUIT
- +5 ; not OR pkg
- IF $PIECE(X,U,5)'=+$ORDER(^DIC(9.4,"C","OR",0))
- QUIT
- +6 ; nature=auto
- IF $PIECE(X,U,7)=+$ORDER(^ORD(100.02,"C","A",0))
- QUIT
- +7 IF $PIECE(X,U)="EHRM TRANSITIONED UTILITY"
- QUIT
- +8 IF $PIECE(X,U)="EHRM TRANSITIONED"
- IF '$$ONEHR^ORACCESS()
- QUIT
- +9 SET ARRAY($PIECE(X,U))="i"_IEN_U_$PIECE(X,U)
- End DoDot:1
- +10 DO GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
- +11 ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
- +12 FOR CNT=1:1:SEQARR
- Begin DoDot:1
- +13 SET IEN=$PIECE(SEQARR(CNT),U,2)
- SET NAME=$PIECE(^ORD(100.03,IEN,0),U)
- +14 SET ILST=ILST+1
- SET LST(ILST)="i"_IEN_U_NAME
- +15 IF $DATA(ARRAY(NAME))>0
- KILL ARRAY(NAME)
- End DoDot:1
- +16 IF $DATA(ARRAY)'>0
- QUIT
- +17 SET NAME=""
- FOR
- SET NAME=$ORDER(ARRAY(NAME))
- if NAME=""
- QUIT
- Begin DoDot:1
- +18 SET ILST=ILST+1
- SET LST(ILST)=ARRAY(NAME)
- End DoDot:1
- +19 QUIT
- SM(ERROR) ; Send message to Radiology users
- +1 KILL XMY
- NEW XMDUZ,XMSUB,XMTEXT,OR0,ORIFN,DFN,OIP,OI,ORERR,MG
- +2 SET XMDUZ="CPRS,ORDERS"
- SET MG=$$GET^XPAR("SYS","OR RADIOLOGY ISSUES")
- IF MG=""
- QUIT
- +3 SET XMY("G."_MG)=""
- SET XMSUB="CPRS Order Error on Radiology Order"
- +4 SET XMTEXT="ORERR("
- SET ORIFN=+ERROR
- +5 SET OR0=$GET(^OR(100,ORIFN,0))
- SET DFN=+$PIECE(OR0,"^",2)
- SET OIP=$ORDER(^OR(100,ORIFN,4.5,"ID","ORDERABLE",0))
- SET OI=$GET(^OR(100,ORIFN,4.5,OIP,1))
- +6 SET ORERR(1,0)="Patient: "_$PIECE($GET(^DPT(DFN,0)),"^")
- +7 SET ORERR(2,0)="CPRS Order Number: "_ORIFN
- +8 SET ORERR(3,0)="CPRS Orderable Item: "_OI_" - "_$PIECE($GET(^ORD(101.43,OI,0)),"^")
- +9 SET ORERR(4,0)=" "
- +10 SET ORERR(5,0)="Error from Radiology: "_$PIECE(ERROR,"^",4)
- +11 DO ^XMD
- +12 QUIT
- CHKLABDIV(ORDITEM,ORXREF) ; Compare user's signed in division to lab test
- +1 ; division(s)
- +2 IF "^S.LAB^S.AP^"'[(U_ORXREF_U)
- QUIT 1
- +3 IF '+$GET(DUZ(2))
- QUIT 1
- +4 NEW ORTESTIEN
- +5 SET ORTESTIEN=$PIECE($PIECE($GET(^ORD(101.43,ORDITEM,0)),U,2),";",1)
- +6 IF '+ORTESTIEN
- QUIT 1
- +7 IF +$ORDER(^LAB(60,ORTESTIEN,8,0))=0
- QUIT 1
- +8 NEW ORLABOK,ORINSTTYPES,ORDIV,ORDIVS,OREXIST
- +9 ;OUTPATIENT CLINIC SHOULD SHOW OUTPATIENT CLINIC'S AND PARENT FACILITY'S TESTS
- +10 SET ORINSTTYPES("CBOC")=""
- SET ORINSTTYPES("OCMC")=""
- SET ORINSTTYPES("OCS")=""
- +11 SET ORINSTTYPES("OPC")=""
- SET ORINSTTYPES("RO-OC")=""
- +12 SET ORDIVS=1
- SET ORDIVS(1)=DUZ(2)_U_$$NNT^XUAF4(DUZ(2))
- +13 IF $DATA(ORINSTTYPES($PIECE(ORDIVS(1),U,4)))=1
- Begin DoDot:1
- +14 SET ORDIV=+$$PRNT^XUAF4($PIECE(ORDIVS(ORDIVS),U,3))
- +15 if ORDIV>0
- SET ORDIVS=2
- SET ORDIVS(2)=ORDIV_U_$$NNT^XUAF4(ORDIV)
- End DoDot:1
- +16 SET ORLABOK=1
- +17 FOR ORDIV=1:1:ORDIVS
- Begin DoDot:1
- +18 SET OREXIST=$DATA(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV)))
- +19 SET ORLABOK=(OREXIST>9)
- +20 IF 'ORLABOK
- QUIT
- +21 SET ORLABOK=($PIECE($GET(^LAB(60,ORTESTIEN,8,+ORDIVS(ORDIV),0)),U,3)'=1)
- End DoDot:1
- if OREXIST
- QUIT
- +22 QUIT ORLABOK