- ORWDX2 ; SLC/JM/AGP - Order dialog utilities ;20-Jun-2014 09:43;DU
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,1013**;Dec 17, 1997;Build 242
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;IHS/MSC/MGH Modified XROOT for ICD codes for ICD-10 Patch 1013
- ;
- 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,SAVCLIN,SAVSNO
- S SAVCLIN="",SAVSNO=""
- S (ILST,I)=0,CHKDOSE=$$CHKDOSES
- S CNT=0
- F S I=$O(@ROOT@(I)) Q:I'>0 D
- . S DLG=$P(@ROOT@(I,0),U,2),INST=$P(^(0),U,3)
- . Q:'DLG
- . S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
- . I '$L(ID) S ID="ID"_DLG
- . S VAL=$G(@ROOT@(I,1))
- . S CNT=CNT+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
- . I $P($G(^ORD(101.41,DLG,0)),U)="OR GTX CLININD2" S SAVCLIN="~"_DLG_U_INST_U_ID Q ;IHS/MSC/MGH Patch 1013
- . 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 $P($G(^ORD(101.41,DLG,0)),U)="OR GTX SNMDCNPTID" S SAVSNO=VAL ;IHS/MSC/MGH Patch 1013
- . 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))
- ;IHS/MSC/MGH Patch 1013 changes
- I SAVSNO'="" D
- .S ^TMP("MGH","SNO")=SAVSNO
- .S VAL=$P($$CONC^BSTSAPI(SAVSNO_"^^^1"),U,5)
- .I SAVCLIN="" D
- ..S DLG=$O(^ORD(101.41,"B","OR GTX CLININD2",""))
- ..S ID=$P($G(^ORD(101.41,DLG,1)),U,3)
- ..S INST=1
- ..S LST($$NXT)="~"_DLG_U_INST_U_ID
- .E S LST($$NXT)=SAVCLIN
- .S LST($$NXT)="i"_VAL,LST($$NXT)="e"_VAL
- ;END MOD
- I CHKDOSE D FIXDOSES
- 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
- ;
- 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
- . 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
- ORWDX2 ; SLC/JM/AGP - Order dialog utilities ;20-Jun-2014 09:43;DU
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**246,243,1013**;Dec 17, 1997;Build 242
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;IHS/MSC/MGH Modified XROOT for ICD codes for ICD-10 Patch 1013
- +4 ;
- +5 QUIT
- +6 ;
- 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,SAVCLIN,SAVSNO
- +2 SET SAVCLIN=""
- SET SAVSNO=""
- +3 SET (ILST,I)=0
- SET CHKDOSE=$$CHKDOSES
- +4 SET CNT=0
- +5 FOR
- SET I=$ORDER(@ROOT@(I))
- IF I'>0
- QUIT
- Begin DoDot:1
- +6 SET DLG=$PIECE(@ROOT@(I,0),U,2)
- SET INST=$PIECE(^(0),U,3)
- +7 IF 'DLG
- QUIT
- +8 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
- +9 IF '$LENGTH(ID)
- SET ID="ID"_DLG
- +10 SET VAL=$GET(@ROOT@(I,1))
- +11 SET CNT=CNT+1
- +12 IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX ADDITIVE"
- SET ID="ADDITIVE"
- +13 ; skip literal start time on copy
- IF $EXTRACT(RSPID)="C"
- IF (ID="START")
- IF VAL
- QUIT
- +14 ;IHS/MSC/MGH Patch 1013
- IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX CLININD2"
- SET SAVCLIN="~"_DLG_U_INST_U_ID
- QUIT
- +15 SET LST($$NXT)="~"_DLG_U_INST_U_ID
- +16 IF $LENGTH(VAL)
- Begin DoDot:2
- +17 SET LST($$NXT)="i"_VAL
- SET LST($$NXT)="e"_$$EXTVAL(VAL,DLG)
- +18 IF CHKDOSE
- DO DOSEINFO
- End DoDot:2
- +19 ;IHS/MSC/MGH Patch 1013
- IF $PIECE($GET(^ORD(101.41,DLG,0)),U)="OR GTX SNMDCNPTID"
- SET SAVSNO=VAL
- +20 IF $DATA(@ROOT@(I,2))>1
- Begin DoDot:2
- +21 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
- +22 SET J=0
- FOR
- SET J=$ORDER(@ROOT@(I,2,J))
- IF J'>0
- QUIT
- Begin DoDot:3
- +23 SET LST($$NXT)="t"_$G(@ROOT@(I,2,J,0))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +24 ;IHS/MSC/MGH Patch 1013 changes
- +25 IF SAVSNO'=""
- Begin DoDot:1
- +26 SET ^TMP("MGH","SNO")=SAVSNO
- +27 SET VAL=$PIECE($$CONC^BSTSAPI(SAVSNO_"^^^1"),U,5)
- +28 IF SAVCLIN=""
- Begin DoDot:2
- +29 SET DLG=$ORDER(^ORD(101.41,"B","OR GTX CLININD2",""))
- +30 SET ID=$PIECE($GET(^ORD(101.41,DLG,1)),U,3)
- +31 SET INST=1
- +32 SET LST($$NXT)="~"_DLG_U_INST_U_ID
- End DoDot:2
- +33 IF '$TEST
- SET LST($$NXT)=SAVCLIN
- +34 SET LST($$NXT)="i"_VAL
- SET LST($$NXT)="e"_VAL
- End DoDot:1
- +35 ;END MOD
- +36 IF CHKDOSE
- DO FIXDOSES
- +37 IF $EXTRACT(ROOT,1,4)="^TMP"
- KILL ^TMP("ORWDXMQ",$JOB)
- +38 QUIT
- +39 ;
- 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 ;
- 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 SET ARRAY($PIECE(X,U))="i"_IEN_U_$PIECE(X,U)
- End DoDot:1
- +8 DO GETLST^XPAR(.SEQARR,"SYS","OR DC REASON LIST","Q",.ERROR)
- +9 ;S CNT=0 F S CNT=$O(SEQARR(CNT)) Q:CNT'>0 D
- +10 FOR CNT=1:1:SEQARR
- Begin DoDot:1
- +11 SET IEN=$PIECE(SEQARR(CNT),U,2)
- SET NAME=$PIECE(^ORD(100.03,IEN,0),U)
- +12 SET ILST=ILST+1
- SET LST(ILST)="i"_IEN_U_NAME
- +13 IF $DATA(ARRAY(NAME))>0
- KILL ARRAY(NAME)
- End DoDot:1
- +14 IF $DATA(ARRAY)'>0
- QUIT
- +15 SET NAME=""
- FOR
- SET NAME=$ORDER(ARRAY(NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +16 SET ILST=ILST+1
- SET LST(ILST)=ARRAY(NAME)
- End DoDot:1
- +17 QUIT
