ORCHTAB2 ;SLC/MKB/REV-Add item to tab listing cont ;05-Nov-2010 08:31;DU
;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,58,1008,181,1010**;Dec 17, 1997;Build 47
;Modified - IHS/MSC/MGH - 11/5/2010 - Line GMRA+4 Modifed to display no assessment available
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")
S UNASS=$$UNASS^GMRAOR1(+ORVP)
I UNASS=0 S X="Not Asssessible" D LINE^ORCHTAB
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
;I $E(ORX,1,3)=" " S X=ORX D TXT^ORCHTAB Q ;comment line only ??
S X=$P(ORX,U,3)_$S($L($P(ORX,U,4)):" ("_$P(ORX,U,4)_")",1:"")
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
ORCHTAB2 ;SLC/MKB/REV-Add item to tab listing cont ;05-Nov-2010 08:31;DU
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**27,58,1008,181,1010**;Dec 17, 1997;Build 47
+2 ;Modified - IHS/MSC/MGH - 11/5/2010 - Line GMRA+4 Modifed to display no assessment available
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 SET UNASS=$$UNASS^GMRAOR1(+ORVP)
+5 IF UNASS=0
SET X="Not Asssessible"
DO LINE^ORCHTAB
+6 IF '$GET(ORY)
SET X=$SELECT($GET(ORY)="":"No assessment available",1:"No known allergies")
DO LINE^ORCHTAB
QUIT
+7 SET ORI=0
FOR
SET ORI=$ORDER(ORY(ORI))
IF ORI'>0
QUIT
Begin DoDot:1
+8 SET ALLG=$PIECE(ORY(ORI),U)
SET SEV=$PIECE(ORY(ORI),U,2)
SET ID=$PIECE(ORY(ORI),U,3)
+9 SET X=$SELECT($LENGTH(SEV):$$LOWER^VALM1(SEV)_" reaction to ",1:"")_ALLG
+10 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))
+11 IF $LENGTH(SIGNS)
SET X=X_" ("_SIGNS_")"
+12 IF $LENGTH(X)'>ORMAX
SET ORTX=1
SET ORTX(1)=X
IF $LENGTH(X)>ORMAX
DO TXT^ORCHTAB
+13 SET DATA(1)=$$DATE^ORCHTAB($PIECE(^GMR(120.8,ID,0),U,4))
SET DATA=1
SET ORIFN="GMRA"
+14 DO ADD^ORCHTAB
End DoDot:1
+15 QUIT
+16 ;
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 ;I $E(ORX,1,3)=" " S X=ORX D TXT^ORCHTAB Q ;comment line only ??
+4 SET X=$PIECE(ORX,U,3)_$SELECT($LENGTH($PIECE(ORX,U,4)):" ("_$PIECE(ORX,U,4)_")",1:"")
+5 IF $LENGTH(X)'>ORMAX
SET ORTX=1
SET ORTX(1)=X
IF $LENGTH(X)>ORMAX
DO TXT^ORCHTAB
+6 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
+7 ;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
+8 SET FIRST=LCNT+1
DO ADD^ORCHTAB
+9 ; unverified flag ($)
IF $LENGTH($PIECE(ORX,U,10))
SET $EXTRACT(^TMP("OR",$JOB,ORTAB,FIRST,0),5)=$PIECE(ORX,U,10)
+10 ; CSV change - check for active code, for active problem list only
+11 ; Inactive code flag (#) takes precedence and replaces unverified flag ($)
+12 IF $PIECE(ORX,U,2)="A"
IF '$$CODESTS^GMPLX(ID,DT)
SET $EXTRACT(^TMP("OR",$JOB,ORTAB,FIRST,0),5)="#"
+13 QUIT
+14 ;
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
