- ORCHTAB2 ;SLC/MKB/REV-Add item to tab listing cont ;03/18/11 12:02
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,58,181,306**;Dec 17, 1997;Build 43
- GMRA ; -- allergies
- N ORY,ORI,ALLG,SEV,ID,SIGNS,J,ORIFN,DATA,X,ORTX
- D SUBHDR^ORCHTAB("Allergies/Adverse Reactions")
- D EN1^GMRAOR1(+ORVP,"ORY")
- I '$G(ORY) S X=$S($G(ORY)="":"No assessment available",1:"No known allergies") D LINE^ORCHTAB Q
- S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 D
- . S ALLG=$P(ORY(ORI),U),SEV=$P(ORY(ORI),U,2),ID=$P(ORY(ORI),U,3)
- . S X=$S($L(SEV):$$LOWER^VALM1(SEV)_" reaction to ",1:"")_ALLG
- . S SIGNS="",J=0 F S J=$O(ORY(ORI,"S",J)) Q:J'>0 S SIGNS=SIGNS_$S($L(SIGNS):", ",1:"")_$$LOW^XLFSTR(ORY(ORI,"S",J))
- . S:$L(SIGNS) X=X_" ("_SIGNS_")"
- . S:$L(X)'>ORMAX ORTX=1,ORTX(1)=X I $L(X)>ORMAX D TXT^ORCHTAB
- . S DATA(1)=$$DATE^ORCHTAB($P(^GMR(120.8,ID,0),U,4)),DATA=1,ORIFN="GMRA"
- . D ADD^ORCHTAB
- Q
- ;
- GMRV ; -- Vitals
- N ORY,ORI,X,Y,DATA
- D SUBHDR^ORCHTAB("Recent Vitals"),FASTVIT^ORQQVI(.ORY,+ORVP)
- I '$O(ORY(0)) S X="No data available" D LINE^ORCHTAB Q
- S ORI=0 F S ORI=$O(ORY(ORI)) Q:ORI'>0 D
- . S Y=$P(ORY(ORI),U,5)_" "_$P(ORY(ORI),U,6) S:$L(Y)'>1 Y=$P(ORY(ORI),U,3)
- . S X=$P(ORY(ORI),U,2),X=$S(X="BP":"B/P: ",X="HT":"Ht: ",X="P":"Pulse: ",X="R":"Resp: ",X="T":"Temp: ",X="WT":"Wt: ",X="PN":"Pain: ",1:$$LJ^XLFSTR(X_":",7))_Y
- . S DATA=$$DATETIME^ORCHTAB($P(ORY(ORI),U,4))
- . D LINE^ORCHTAB
- Q
- ;
- IMM ; -- Immunizations
- N ORIMM,ORIDT,ORI,X,Y,DATA K ^TMP("PXI",$J)
- D SUBHDR^ORCHTAB("Recent Immunizations"),IMMUN^PXRHS03(+ORVP)
- S ORIMM=0 F S ORIMM=$O(^TMP("PXI",$J,ORIMM)) Q:ORIMM="" D
- . S ORIDT=$O(^TMP("PXI",$J,ORIMM,0)),ORI=$O(^(ORIDT,0)),Y=$G(^(ORI,0))
- . S X=ORIMM_$S($L($P(Y,U,6)):" ("_$P(Y,U,6)_")",1:"")
- . S DATA=$S('ORI:"",1:$$DATETIME^ORCHTAB($P(Y,U,3)))
- . D LINE^ORCHTAB
- Q
- ;
- SC ; -- Service Connected data
- N DFN,VAEL,VASV,VAERR,X,DATA
- S DFN=+ORVP D 7^VADPT,SUBHDR^ORCHTAB("Eligibility")
- I VAEL(3) S X="Service Connected "_$P(VAEL(3),U,2)_"%"
- E S X="Not Service Connected"
- D LINE^ORCHTAB
- I VASV(2) S X="Agent Orange Exposure" D LINE^ORCHTAB
- I VASV(3) S X="Radiation Exposure" D LINE^ORCHTAB
- I $P($G(^DPT(+ORVP,.322)),U,10) S X="Environmental Contaminants exposure" D LINE^ORCHTAB
- Q
- ;
- CWAD ; -- postings
- N ORI,ORX,MSG,CNT,X,ID,DATA,ORIFN,ORTX K ^TMP("TIUPPCV",$J)
- D SUBHDR^ORCHTAB("Patient Postings")
- D ENCOVER^TIUPP3(+ORVP)
- S CNT=0,ORIFN="TIU"
- S ORI=0 F S ORI=$O(^TMP("TIUPPCV",$J,ORI)) Q:ORI'>0 S ORX=$G(^(ORI)) D
- . S ID=$P(ORX,U) Q:'$L(ID)
- . S X=$P(ORX,U,3),DATA(1)=$$DATETIME^ORCHTAB($P(ORX,U,5)),DATA=1
- . S:$L(X)'>ORMAX ORTX=1,ORTX(1)=X I $L(X)>ORMAX D TXT^ORCHTAB
- . D ADD^ORCHTAB S CNT=CNT+1
- I 'CNT S LCNT=LCNT+1,^TMP("OR",$J,ORTAB,LCNT,0)=" "_$$PAD^ORCHTAB("<None>",40)_"|"
- K ^TMP("TIUPPCV",$J)
- Q
- ;
- PROB ; -- problem
- N ID,DATA,X,ORTX,FIRST,ORJ,ORIFN
- S ID=$P(ORX,U),ORIFN=$P(ORX,U,2) ;problem ptr, status
- S X=$P(ORX,U,3)
- S:$L(X)'>ORMAX ORTX=1,ORTX(1)=X I $L(X)>ORMAX D TXT^ORCHTAB
- S DATA(1)=$$PAD^ORCHTAB($$DATE^ORCHTAB($P(ORX,U,5)),10)_$$PAD^ORCHTAB($$DATE^ORCHTAB($P(ORX,U,6)),10)_$S($P(ORX,U,2)="I":"inactive",1:"active "_$P(ORX,U,9)),DATA=1
- I COMM,$O(ORY(ORI,0)) S ORJ=0 F S ORJ=$O(ORY(ORI,ORJ)) Q:ORJ'>0 S X=" "_ORY(ORI,ORJ) I $L(X)>1 S ORTX=ORTX+1,ORTX(ORTX)="" D TXT^ORCHTAB ;add comments
- S FIRST=LCNT+1 D ADD^ORCHTAB
- I $L($P(ORX,U,10)) S $E(^TMP("OR",$J,ORTAB,FIRST,0),5)=$P(ORX,U,10) ; unverified flag ($)
- ; CSV change - check for active code, for active problem list only
- ; Inactive code flag (#) takes precedence and replaces unverified flag ($)
- I $P(ORX,U,2)="A",'$$CODESTS^GMPLX(ID,DT) S $E(^TMP("OR",$J,ORTAB,FIRST,0),5)="#"
- Q
- ;
- NOTE ; -- progress note
- N ID,DATA,X,ORTX
- S DATA(1)=$$PAD^ORCHTAB($$DATETIME^ORCHTAB($P(ORX,U,3)),16)_$$PAD^ORCHTAB($$LNAMEF^ORCHTAB(+$P(ORX,U,5)),12)_$E($P(ORX,U,7),1,5),DATA=1
- S ID=$P(ORX,U),X=$P(ORX,U,2)
- S:$L(X)'>ORMAX ORTX=1,ORTX(1)=X I $L(X)>ORMAX D TXT^ORCHTAB
- I SUBJ,$L($P(ORX,U,12)) S X=" "_$P(ORX,U,12),ORTX=ORTX+1,ORTX(ORTX)="" D TXT^ORCHTAB ;add note subject
- D ADD^ORCHTAB
- Q
- ;
- SUMM ; -- discharge summary
- N ID,DATA,ORTX
- S DATA(1)=$$DATE^ORCHTAB($P(ORX,U,3))_" "_$$PAD^ORCHTAB($$LNAMEF^ORCHTAB(+$P(ORX,U,5)),15)_$E($P(ORX,U,7),1,5)_$P($P(ORX,U,8)," ",2)_" "_$P($P(ORX,U,9)," ",2)
- S ID=$P(ORX,U),ORTX=1,ORTX(1)=$P(ORX,U,2),DATA=1
- D ADD^ORCHTAB
- Q
- ;
- INITIALS(USER) ; -- Return initials of USER
- N X,Y S X=$G(^VA(200,+$G(USER),0)),Y=$P(X,U,2)
- S:'$L(Y) Y=" x "
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCHTAB2 4494 printed Feb 18, 2025@23:55:01 Page 2
- ORCHTAB2 ;SLC/MKB/REV-Add item to tab listing cont ;03/18/11 12:02
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,58,181,306**;Dec 17, 1997;Build 43
- GMRA ; -- allergies
- +1 NEW ORY,ORI,ALLG,SEV,ID,SIGNS,J,ORIFN,DATA,X,ORTX
- +2 DO SUBHDR^ORCHTAB("Allergies/Adverse Reactions")
- +3 DO EN1^GMRAOR1(+ORVP,"ORY")
- +4 IF '$GET(ORY)
- SET X=$SELECT($GET(ORY)="":"No assessment available",1:"No known allergies")
- DO LINE^ORCHTAB
- QUIT
- +5 SET ORI=0
- FOR
- SET ORI=$ORDER(ORY(ORI))
- if ORI'>0
- QUIT
- Begin DoDot:1
- +6 SET ALLG=$PIECE(ORY(ORI),U)
- SET SEV=$PIECE(ORY(ORI),U,2)
- SET ID=$PIECE(ORY(ORI),U,3)
- +7 SET X=$SELECT($LENGTH(SEV):$$LOWER^VALM1(SEV)_" reaction to ",1:"")_ALLG
- +8 SET SIGNS=""
- SET J=0
- FOR
- SET J=$ORDER(ORY(ORI,"S",J))
- if J'>0
- QUIT
- SET SIGNS=SIGNS_$SELECT($LENGTH(SIGNS):", ",1:"")_$$LOW^XLFSTR(ORY(ORI,"S",J))
- +9 if $LENGTH(SIGNS)
- SET X=X_" ("_SIGNS_")"
- +10 if $LENGTH(X)'>ORMAX
- SET ORTX=1
- SET ORTX(1)=X
- IF $LENGTH(X)>ORMAX
- DO TXT^ORCHTAB
- +11 SET DATA(1)=$$DATE^ORCHTAB($PIECE(^GMR(120.8,ID,0),U,4))
- SET DATA=1
- SET ORIFN="GMRA"
- +12 DO ADD^ORCHTAB
- End DoDot:1
- +13 QUIT
- +14 ;
- GMRV ; -- Vitals
- +1 NEW ORY,ORI,X,Y,DATA
- +2 DO SUBHDR^ORCHTAB("Recent Vitals")
- DO FASTVIT^ORQQVI(.ORY,+ORVP)
- +3 IF '$ORDER(ORY(0))
- SET X="No data available"
- DO LINE^ORCHTAB
- QUIT
- +4 SET ORI=0
- FOR
- SET ORI=$ORDER(ORY(ORI))
- if ORI'>0
- QUIT
- Begin DoDot:1
- +5 SET Y=$PIECE(ORY(ORI),U,5)_" "_$PIECE(ORY(ORI),U,6)
- if $LENGTH(Y)'>1
- SET Y=$PIECE(ORY(ORI),U,3)
- +6 SET X=$PIECE(ORY(ORI),U,2)
- SET X=$SELECT(X="BP":"B/P: ",X="HT":"Ht: ",X="P":"Pulse: ",X="R":"Resp: ",X="T":"Temp: ",X="WT":"Wt: ",X="PN":"Pain: ",1:$$LJ^XLFSTR(X_":",7))_Y
- +7 SET DATA=$$DATETIME^ORCHTAB($PIECE(ORY(ORI),U,4))
- +8 DO LINE^ORCHTAB
- End DoDot:1
- +9 QUIT
- +10 ;
- IMM ; -- Immunizations
- +1 NEW ORIMM,ORIDT,ORI,X,Y,DATA
- KILL ^TMP("PXI",$JOB)
- +2 DO SUBHDR^ORCHTAB("Recent Immunizations")
- DO IMMUN^PXRHS03(+ORVP)
- +3 SET ORIMM=0
- FOR
- SET ORIMM=$ORDER(^TMP("PXI",$JOB,ORIMM))
- if ORIMM=""
- QUIT
- Begin DoDot:1
- +4 SET ORIDT=$ORDER(^TMP("PXI",$JOB,ORIMM,0))
- SET ORI=$ORDER(^(ORIDT,0))
- SET Y=$GET(^(ORI,0))
- +5 SET X=ORIMM_$SELECT($LENGTH($PIECE(Y,U,6)):" ("_$PIECE(Y,U,6)_")",1:"")
- +6 SET DATA=$SELECT('ORI:"",1:$$DATETIME^ORCHTAB($PIECE(Y,U,3)))
- +7 DO LINE^ORCHTAB
- End DoDot:1
- +8 QUIT
- +9 ;
- SC ; -- Service Connected data
- +1 NEW DFN,VAEL,VASV,VAERR,X,DATA
- +2 SET DFN=+ORVP
- DO 7^VADPT
- DO SUBHDR^ORCHTAB("Eligibility")
- +3 IF VAEL(3)
- SET X="Service Connected "_$PIECE(VAEL(3),U,2)_"%"
- +4 IF '$TEST
- SET X="Not Service Connected"
- +5 DO LINE^ORCHTAB
- +6 IF VASV(2)
- SET X="Agent Orange Exposure"
- DO LINE^ORCHTAB
- +7 IF VASV(3)
- SET X="Radiation Exposure"
- DO LINE^ORCHTAB
- +8 IF $PIECE($GET(^DPT(+ORVP,.322)),U,10)
- SET X="Environmental Contaminants exposure"
- DO LINE^ORCHTAB
- +9 QUIT
- +10 ;
- CWAD ; -- postings
- +1 NEW ORI,ORX,MSG,CNT,X,ID,DATA,ORIFN,ORTX
- KILL ^TMP("TIUPPCV",$JOB)
- +2 DO SUBHDR^ORCHTAB("Patient Postings")
- +3 DO ENCOVER^TIUPP3(+ORVP)
- +4 SET CNT=0
- SET ORIFN="TIU"
- +5 SET ORI=0
- FOR
- SET ORI=$ORDER(^TMP("TIUPPCV",$JOB,ORI))
- if ORI'>0
- QUIT
- SET ORX=$GET(^(ORI))
- Begin DoDot:1
- +6 SET ID=$PIECE(ORX,U)
- if '$LENGTH(ID)
- QUIT
- +7 SET X=$PIECE(ORX,U,3)
- SET DATA(1)=$$DATETIME^ORCHTAB($PIECE(ORX,U,5))
- SET DATA=1
- +8 if $LENGTH(X)'>ORMAX
- SET ORTX=1
- SET ORTX(1)=X
- IF $LENGTH(X)>ORMAX
- DO TXT^ORCHTAB
- +9 DO ADD^ORCHTAB
- SET CNT=CNT+1
- End DoDot:1
- +10 IF 'CNT
- SET LCNT=LCNT+1
- SET ^TMP("OR",$JOB,ORTAB,LCNT,0)=" "_$$PAD^ORCHTAB("<None>",40)_"|"
- +11 KILL ^TMP("TIUPPCV",$JOB)
- +12 QUIT
- +13 ;
- PROB ; -- problem
- +1 NEW ID,DATA,X,ORTX,FIRST,ORJ,ORIFN
- +2 ;problem ptr, status
- SET ID=$PIECE(ORX,U)
- SET ORIFN=$PIECE(ORX,U,2)
- +3 SET X=$PIECE(ORX,U,3)
- +4 if $LENGTH(X)'>ORMAX
- SET ORTX=1
- SET ORTX(1)=X
- IF $LENGTH(X)>ORMAX
- DO TXT^ORCHTAB
- +5 SET DATA(1)=$$PAD^ORCHTAB($$DATE^ORCHTAB($PIECE(ORX,U,5)),10)_$$PAD^ORCHTAB($$DATE^ORCHTAB($PIECE(ORX,U,6)),10)_$SELECT($PIECE(ORX,U,2)="I":"inactive",1:"active "_$PIECE(ORX,U,9))
- SET DATA=1
- +6 ;add comments
- IF COMM
- IF $ORDER(ORY(ORI,0))
- SET ORJ=0
- FOR
- SET ORJ=$ORDER(ORY(ORI,ORJ))
- if ORJ'>0
- QUIT
- SET X=" "_ORY(ORI,ORJ)
- IF $LENGTH(X)>1
- SET ORTX=ORTX+1
- SET ORTX(ORTX)=""
- DO TXT^ORCHTAB
- +7 SET FIRST=LCNT+1
- DO ADD^ORCHTAB
- +8 ; unverified flag ($)
- IF $LENGTH($PIECE(ORX,U,10))
- SET $EXTRACT(^TMP("OR",$JOB,ORTAB,FIRST,0),5)=$PIECE(ORX,U,10)
- +9 ; CSV change - check for active code, for active problem list only
- +10 ; Inactive code flag (#) takes precedence and replaces unverified flag ($)
- +11 IF $PIECE(ORX,U,2)="A"
- IF '$$CODESTS^GMPLX(ID,DT)
- SET $EXTRACT(^TMP("OR",$JOB,ORTAB,FIRST,0),5)="#"
- +12 QUIT
- +13 ;
- NOTE ; -- progress note
- +1 NEW ID,DATA,X,ORTX
- +2 SET DATA(1)=$$PAD^ORCHTAB($$DATETIME^ORCHTAB($PIECE(ORX,U,3)),16)_$$PAD^ORCHTAB($$LNAMEF^ORCHTAB(+$PIECE(ORX,U,5)),12)_$EXTRACT($PIECE(ORX,U,7),1,5)
- SET DATA=1
- +3 SET ID=$PIECE(ORX,U)
- SET X=$PIECE(ORX,U,2)
- +4 if $LENGTH(X)'>ORMAX
- SET ORTX=1
- SET ORTX(1)=X
- IF $LENGTH(X)>ORMAX
- DO TXT^ORCHTAB
- +5 ;add note subject
- IF SUBJ
- IF $LENGTH($PIECE(ORX,U,12))
- SET X=" "_$PIECE(ORX,U,12)
- SET ORTX=ORTX+1
- SET ORTX(ORTX)=""
- DO TXT^ORCHTAB
- +6 DO ADD^ORCHTAB
- +7 QUIT
- +8 ;
- SUMM ; -- discharge summary
- +1 NEW ID,DATA,ORTX
- +2 SET DATA(1)=$$DATE^ORCHTAB($PIECE(ORX,U,3))_" "_$$PAD^ORCHTAB($$LNAMEF^ORCHTAB(+$PIECE(ORX,U,5)),15)_$EXTRACT($PIECE(ORX,U,7),1,5)_$PIECE($PIECE(ORX,U,8)," ",2)_" "_$PIECE($PIECE(ORX,U,9)," ",2)
- +3 SET ID=$PIECE(ORX,U)
- SET ORTX=1
- SET ORTX(1)=$PIECE(ORX,U,2)
- SET DATA=1
- +4 DO ADD^ORCHTAB
- +5 QUIT
- +6 ;
- INITIALS(USER) ; -- Return initials of USER
- +1 NEW X,Y
- SET X=$GET(^VA(200,+$GET(USER),0))
- SET Y=$PIECE(X,U,2)
- +2 if '$LENGTH(Y)
- SET Y=" x "
- +3 QUIT Y