BJPNPBDT ;GDIT/HS/BEE-Prenatal Care Module - Retrieve Detail History ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
;
Q
;
DET(DATA,PIP) ;EP - BJPN PROBLEM DETAIL
;
;This RPC returns the problem detail for a Problem entry (including past deletes)
;
;Input:
; PIP - Pointer to Prenatal Problem file entry
;
NEW UID,II,TMP,PRBIEN,RET,VIEW,TCNT,ACNT,LINE,TMP1
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNPBDT",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S TMP=$NA(^TMP("BJPNPDT1",UID))
K @TMP
S RET=$NA(^TMP("BJPNPDET",UID))
K @RET
;
S $P(LINE,"-",60)="-"
;
S II=0
;NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPBDT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(II)="T01024REPORT_TEXT"_$C(30)
;
I $G(PIP)="" S BMXSEC="INVALID PIP IEN" G XDET
;
;Get the IPL pointer
S PRBIEN=$$GET1^DIQ(90680.01,PIP_",",.1,"I") I PRBIEN="" S BMXSEC="Invalid IPL pointer in PIP entry" G XDET
;
;Retrieve the audit history
D ACOMP^BJPNFAUD(.RET,PIP,PRBIEN)
;
;Compile the information by date/time and user
S ADT="",(ACNT,TCNT)=0 F S ADT=$O(@RET@(ADT)) Q:ADT="" S USER="" F S USER=$O(@RET@(ADT,USER)) Q:USER="" D
. ;
. NEW N,V,G,CHG
. ;
. ;Update event counter
. S ACNT=ACNT+1
. D SV("",LINE)
. ;
. S G=$NA(@RET@(ADT,USER))
. ;
. ;See if the last one
. I '$$NEXT(.RET,ADT,USER) D
.. D SV("","CURRENT PIP/IPL DISPLAY")
.. D SV()
. ;
. ;IPL Change Header
. D SV("","IPL Listing:")
. D SV()
. ;
. ;IPL Add/Edit
. I $D(@G@("DIAGNOSIS")) D
.. S N=@G@("DIAGNOSIS")
.. I $P(N,U)="" S VIEW("IPL.01")=$P(N,U,2),CHG("IPL.01")="Problem diagnosis added to IPL" Q
.. S VIEW("IPL.01")=$P(N,U,2),CHG("IPL.01")="IPL Problem diagnosis changed to"
. I $D(VIEW("IPL.01")) D SV("IPL.01","Problem diagnosis")
. ;
. ;Provider Text
. I $D(@G@("PROVIDER NARRATIVE")) D
.. S N=$P(@G@("PROVIDER NARRATIVE"),U,2)
.. S VIEW("IPL.05")=N_U_$S(N]"":"",1:"^1")
.. S CHG("IPL.05")="Provider Narrative set to"
. I $D(VIEW("IPL.05")) D SV("IPL.05","Provider Narrative")
. ;
. ;IPL Status
. I $D(@G@("STATUS")) D
.. S N=$P(@G@("STATUS"),U,2)
.. S VIEW("IPL.12")=N_U_$S(N]"":"",1:"^1")
.. S CHG("IPL.12")="IPL Status set to"
. I $D(VIEW("IPL.12")) D SV("IPL.12","IPL Status")
. ;
. ;IPL Class
. I $D(@G@("CLASS")) D
.. S N=$P(@G@("CLASS"),U,2)
.. S VIEW("IPL.04")=N_$S(N]"":"",1:"^1")
.. S CHG("IPL.04")="IPL Class set to"
. I $D(VIEW("IPL.04")) D SV("IPL.04","IPL Class")
. ;
. ;Date of Onset
. I $D(@G@("DATE OF ONSET")) D
.. S N=$P(@G@("DATE OF ONSET"),U,2)
.. S VIEW("IPL.13")=N_$S(N]"":"",1:"^1")
.. S CHG("IPL.13")="IPL Date of Onset set to"
. I $D(VIEW("IPL.13")) D SV("IPL.13","IPL Date of Onset")
. ;
. ;IPL PIP
. I $D(@G@("PIP")) D
.. S N=$P(@G@("PIP"),U,2)
.. S VIEW("IPL.19")=N_$S(N]"":"",1:"^1")
.. S CHG("IPL.19")="IPL PIP set to"
. I $D(VIEW("IPL.19")) D SV("IPL.19","IPL PIP")
. ;
. ;POV - Ambulatory
. I $D(@G@("USE AS POV (VISIT)")) D
.. ;
.. ;Determine if an add or remove POV
.. S N=@G@("USE AS POV (VISIT)")
.. ;
.. ;Add
.. I $P(N,U,2)]"" D
... S VIEW("APOV."_$P(N,U,3))=$P(N,U,2)
... S CHG("APOV."_$P(N,U,3))="Problem set as POV for visit"
.. ;
.. ;Remove
.. I $P(N,U,2)="" D
... S VIEW("APOV."_$P(N,U,3))=$P(N,U)_U_1
... S CHG("APOV."_$P(N,U,3))="Problem removed as POV for visit"
. I $O(VIEW("APOV."))["APOV." D
.. NEW POV
.. D SV()
.. S POV="APOV." F S POV=$O(VIEW(POV)) Q:POV'["APOV." D
... I $P(VIEW(POV),U,2)'=1 D SV(POV,"Problem used as POV for visit") Q
... S VIEW(POV)=$P(VIEW(POV),U) D SV(POV,"")
... K VIEW(POV)
. ;
. ;POV - Inpatient
. I $D(@G@("USED FOR INPATIENT")) D
.. ;
.. ;Determine if an add or remove POV
.. S N=@G@("USED FOR INPATIENT")
.. ;
.. ;Add
.. I $P(N,U,2)]"" D
... S VIEW("IPOV."_$P(N,U,3))=$P(N,U,2)
... S CHG("IPOV."_$P(N,U,3))="Problem set as POV for inpatient visit"
.. ;
.. ;Remove
.. I $P(N,U,2)="" D
... S VIEW("IPOV."_$P(N,U,3))=$P(N,U)_U_1
... S CHG("IPOV."_$P(N,U,3))="Problem removed as POV for inpatient visit"
. I $O(VIEW("IPOV."))["IPOV." D
.. NEW POV
.. D SV()
.. S POV="IPOV." F S POV=$O(VIEW(POV)) Q:POV'["IPOV." D
... I $P(VIEW(POV),U,2)'=1 D SV(POV,"Problem used as POV for inpatient visit") Q
... S VIEW(POV)=$P(VIEW(POV),U) D SV(POV,"")
... K VIEW(POV)
. ;
. ;Severity Qualifier
. I $D(@G@("SEVERITY")) D
.. S N=$P(@G@("SEVERITY"),U,2)
.. S VIEW("IPL.SEV")=$P($$CONC^BSTSAPI(N_"^^^1"),U,4)_$S(N]"":"",1:"^1")
.. S CHG("IPL.SEV")="Severity Qualifier set to"
. I $D(VIEW("IPL.SEV")) D SV("IPL.SEV","Severity Qualifier")
. ;
. ;PIP Change Header
. D SV()
. D SV("","PIP Listing:")
. D SV()
. ;
. ;PIP Add/Edit
. I $D(@G@("PLACEHOLDER FIELD")) D SV("","Problem Added to PIP")
. ;
. ;PIP Status
. I $D(@G@("CURRENT STATUS")) D
.. S N=$P(@G@("CURRENT STATUS"),U,2)
.. S VIEW("PIP.08")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.08")="PIP Status set to"
. I $D(VIEW("PIP.08")) D SV("PIP.08","PIP Status")
. ;
. ;PIP Scope
. I $D(@G@("CURRENT SCOPE")) D
.. S N=$P(@G@("CURRENT SCOPE"),U,2)
.. S VIEW("PIP.07")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.07")="PIP Scope set to"
. I $D(VIEW("PIP.07")) D SV("PIP.07","PIP Scope")
. ;
. ;PIP Priority
. I $D(@G@("CURRENT PRIORITY")) D
.. S N=$P(@G@("CURRENT PRIORITY"),U,2)
.. S VIEW("PIP.06")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.06")="PIP Priority set to"
. I $D(VIEW("PIP.06")) D SV("PIP.06","PIP Priority")
. ;
. ;PIP Definitive EDD
. I $D(@G@("CURRENT DEFINITIVE EDD")) D
.. S N=$P(@G@("CURRENT DEFINITIVE EDD"),U,2)
.. S VIEW("PIP.09")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.09")="PIP Problem Definitive EDD set to"
. I $D(VIEW("PIP.09")) D SV("PIP.09","PIP Problem Definitive EDD")
. ;
. ;PIP
. I $D(@G@("PIPF")) D
.. S N=$P(@G@("PIPF"),U,2)
.. S VIEW("PIP.5.02")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.5.02")="PIP Flag set to"
. I $D(VIEW("PIP.5.02")) D SV("PIP.5.02","PIP Flag")
. ;
. ;PIP Date
. I $D(@G@("PIP DATE")) D
.. S N=$P(@G@("PIP DATE"),U,2)
.. S VIEW("PIP.5.01")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.5.01")="PIP Flag Date set to"
. I $D(VIEW("PIP.5.01")) D SV("PIP.5.01","PIP Flag Date")
. ;
. ;PIP User
. I $D(@G@("PIP USER")) D
.. S N=$P(@G@("PIP USER"),U,2)
.. S VIEW("PIP.5.03")=N_$S(N]"":"",1:"^1")
.. S CHG("PIP.5.03")="PIP Flag User set to"
. I $D(VIEW("PIP.5.03")) D SV("PIP.5.03","PIP Flag User")
. ;
. ;Goal Notes
. I $O(@G@("GOAL."))["GOAL." D
.. NEW GENT
.. ;
.. ;Loop through each entry
.. S GENT="GOAL." F S GENT=$O(@G@(GENT)) Q:GENT'["GOAL." D
... ;
... NEW CSTS,XSTS,N,NIEN
... S CSTS=$P(GENT,".",2)
... S XSTS=@G@(GENT)
... S N="",NIEN=0 F S NIEN=$O(^AUPNCPL(CSTS,12,NIEN)) Q:'+NIEN D
.... S N=N_$S(N]"":$C(13)_$C(10),1:"")_$G(^AUPNCPL(CSTS,12,NIEN,0))
... S VIEW("GOAL."_CSTS_".A")=XSTS_$S(XSTS="ACTIVE":"",1:"^2")
... S VIEW("GOAL."_CSTS_".N")=N_$S(XSTS="ACTIVE":"",1:"^2")
... S CHG("GOAL."_CSTS_".A")="Goal Note status set to"
... S:XSTS="ACTIVE" CHG("GOAL."_CSTS_".N")="Goal Note set to"
. I $O(VIEW("GOAL."))["GOAL." D
.. D SV(),SV("","GOAL NOTES"),SV()
.. NEW GENT
.. S GENT="GOAL." F S GENT=$O(VIEW(GENT)) Q:GENT'["GOAL." D
... NEW STS,NOTE
... I GENT[".A" D SV(GENT,"Goal Note status")
... I GENT[".N" D SV(GENT,"Goal Note"),SV()
... I $P(VIEW(GENT),U,2)=2 K VIEW(GENT)
. ;
. ;Care Plans
. I $O(@G@("CARE."))["CARE." D
.. NEW GENT
.. ;
.. ;Loop through each entry
.. S GENT="CARE." F S GENT=$O(@G@(GENT)) Q:GENT'["CARE." D
... ;
... NEW CSTS,XSTS,N,NIEN
... S CSTS=$P(GENT,".",2)
... S XSTS=@G@(GENT)
... S N="",NIEN=0 F S NIEN=$O(^AUPNCPL(CSTS,12,NIEN)) Q:'+NIEN D
.... S N=N_$S(N]"":$C(13)_$C(10),1:"")_$G(^AUPNCPL(CSTS,12,NIEN,0))
... S VIEW("CARE."_CSTS_".A")=XSTS_$S(XSTS="ACTIVE":"",1:"^2")
... S VIEW("CARE."_CSTS_".N")=N_$S(XSTS="ACTIVE":"",1:"^2")
... S CHG("CARE."_CSTS_".A")="Care Plan status set to"
... S:XSTS="ACTIVE" CHG("CARE."_CSTS_".N")="Care Plan set to"
. I $O(VIEW("CARE."))["CARE." D
.. D SV(),SV("","CARE PLANS"),SV()
.. NEW GENT
.. S GENT="CARE." F S GENT=$O(VIEW(GENT)) Q:GENT'["CARE." D
... NEW STS,NOTE
... I GENT[".A" D SV(GENT,"Care Plan status")
... I GENT[".N" D SV(GENT,"Care Plan"),SV()
... I $P(VIEW(GENT),U,2)=2 K VIEW(GENT)
. ;
. ;Visit Instructions
. I $O(@G@("VINS."))["VINS." D
.. NEW VENT
.. ;
.. ;Loop through each entry
.. S VENT="VINS." F S VENT=$O(@G@(VENT)) Q:VENT'["VINS." D
... ;
... NEW CSTS,XSTS,N,NIEN,VDT
... S CSTS=$P(VENT,".",2)
... S N="",NIEN=0 F S NIEN=$O(^AUPNVVI(CSTS,11,NIEN)) Q:'+NIEN D
.... S N=N_$S(N]"":$C(13)_$C(10),1:"")_$G(^AUPNVVI(CSTS,11,NIEN,0))
... S VIEW("VINS."_CSTS_".N")=N
... S VIEW("VINS."_CSTS_".D")=$$GET1^DIQ(9000010.58,CSTS_",",.03,"E")
... S CHG("VINS."_CSTS_".N")="Visit Instruction set to"
. I $O(VIEW("VINS."))["VINS." D
.. D SV(),SV("","VISIT INSTRUCTIONS"),SV()
.. NEW VENT
.. S VENT="VINS." F S VENT=$O(VIEW(VENT)) Q:VENT'["VINS." D
... I VENT[".D" D SV(VENT,"Visit Date")
... I VENT[".N" D SV(VENT,"Visit Instruction"),SV()
. ;
. ;Treatment Regimen
. I $O(@G@("VTR."))["VTR." D
.. NEW VENT
.. ;
.. ;Loop through each entry
.. S VENT="VTR." F S VENT=$O(@G@(VENT)) Q:VENT'["VTR." D
... ;
... NEW CSTS,XSTS,N,NIEN,VDT
... S CSTS=$P(VENT,".",2)
... S N=$$GET1^DIQ(9000010.61,CSTS_",",.01,"I") Q:N=""
... S N=$P($$CONC^BSTSAPI(N_"^^^1"),U,4) Q:N=""
... S VIEW("VTR."_CSTS_".N")=N
... S VIEW("VTR."_CSTS_".D")=$$GET1^DIQ(9000010.61,CSTS_",",.03,"E")
... S CHG("VTR."_CSTS_".N")="Treatment Regimen set to"
. I $O(VIEW("VTR."))["VTR." D
.. D SV(),SV("","TREATMENT REGIMEN"),SV()
.. NEW VENT
.. S VENT="VTR." F S VENT=$O(VIEW(VENT)) Q:VENT'["VTR." D
... I VENT[".D" D SV(VENT,"Visit Date")
... I VENT[".N" D SV(VENT,"Treatment Regimen"),SV()
. ;
. ;Education
. I $O(@G@("VEDU."))["VEDU." D
.. NEW VENT
.. ;
.. ;Loop through each entry
.. S VENT="VEDU." F S VENT=$O(@G@(VENT)) Q:VENT'["VEDU." D
... ;
... NEW CSTS,XSTS,N,NIEN,VDT,SCNT,SMD,RED,TIM
... S CSTS=$P(VENT,".",2),SCNT=0
... S N=$$GET1^DIQ(9000010.16,CSTS_",",.01,"E") Q:N=""
... ;S N=$P($$CONC^BSTSAPI(N_"^^^1"),U,4) Q:N=""
... S VIEW("VEDU."_CSTS_".N")=N
... S VIEW("VEDU."_CSTS_".D")=$$GET1^DIQ(9000010.16,CSTS_",",.03,"E")
... S CHG("VEDU."_CSTS_".N")="Patient Education set to"
... ;
... ;Snomed
... S SMD=$$GET1^DIQ(9000010.16,CSTS_",",1301,"I") I SMD]"" D
.... S SCNT=SCNT+1
.... S CHG("VEDU."_CSTS_".S1."_SCNT)="SNOMED Topic set to"
.... S VIEW("VEDU."_CSTS_".S1."_SCNT)=$P($$CONC^BSTSAPI(SMD_"^^^1"),U,4)
... S SMD="" F S SMD=$O(^AUPNVPED(CSTS,26,"B",SMD)) Q:SMD="" D
.... S SCNT=SCNT+1
.... S CHG("VEDU."_CSTS_".S2."_SCNT)="SNOMED set to"
.... S VIEW("VEDU."_CSTS_".S2."_SCNT)=$P($$CONC^BSTSAPI(SMD_"^^^1"),U,4)
... ;
... ;Readiness to learn
... S RED=$$GET1^DIQ(9000010.16,CSTS_",",1102,"E") I RED]"" D
.... S CHG("VEDU."_CSTS_".R1")="Readiness to learn set to"
.... S VIEW("VEDU."_CSTS_".R1")=RED
... ;
... ;Length of Educ (Minutes)
... S TIM=$$GET1^DIQ(9000010.16,CSTS_",",.08,"I") I TIM]"" D
.... S CHG("VEDU."_CSTS_".R2")="Length of education (minutes) set to"
.... S VIEW("VEDU."_CSTS_".R2")=TIM
. I $O(VIEW("VEDU."))["VEDU." D
.. D SV(),SV("","PATIENT EDUCATION")
.. NEW VENT
.. S VENT="VEDU." F S VENT=$O(VIEW(VENT)) Q:VENT'["VEDU." D
... I VENT[".D" D SV(),SV(VENT,"Visit Date")
... I VENT[".N" D SV(VENT,"Patient Education")
... I VENT[".S1" D SV(VENT,"SNOMED Topic")
... I VENT[".S2" D SV(VENT,"SNOMED")
... I VENT[".R2" D SV(VENT,"Length of education (minutes)")
... I VENT[".R1" D SV(VENT,"Readiness to learn")
. ;
. ;Tack on Change on/by
. D SV()
. D SV("","Changes made on: "_$$FMTE^BJPNPRL(ADT))
. D SV("","Changes made by: "_$$GET1^DIQ(200,USER_",",".01","E"))
. D SV(),SV()
. ;
. ;Display current information if this is the last entry
. ;
. ;There is another entry
. I $$NEXT(.RET,ADT,USER) Q
. ;
. ;Qualifiers
. D QUAL(PRBIEN)
. ;
. ;See if the last one
. I '$$NEXT(.RET,ADT,USER) D
.. D SV(),SV("",LINE)
.. D SV("","PIP/IPL ACTIVITY HISTORY")
.. D SV()
;
S ACNT="" F S ACNT=$O(@TMP@(ACNT),-1) Q:ACNT="" D
. S TCNT="" F S TCNT=$O(@TMP@(ACNT,TCNT)) Q:TCNT="" D
.. S II=II+1,@DATA@(II)=@TMP@(ACNT,TCNT)_$C(13)_$C(10)
I II>0 S @DATA@(II)=$G(@DATA@(II))_$C(30)
;
XDET I $G(RET)]"" K @RET
I $G(TMP)]"" K @TMP
S II=II+1,@DATA@(II)=$C(31)
Q
;
NEXT(RET,ADT,USER) ;Check if there is an entry after this one
;
;First see if there is another user entry
I $O(@RET@(ADT,USER))]"" Q 1
;
;Now see if there is another date
I $O(@RET@(ADT))]"" Q 1
;
Q 0
;
SV(P,F) ;Increment the scratch entry
;
S P=$G(P),F=$G(F)
;
;Skip a line
I P="",F="" S TCNT=TCNT+1,@TMP@(ACNT,TCNT)="" Q
;
;Non-data line
I P="",F]"" S TCNT=TCNT+1,@TMP@(ACNT,TCNT)=F Q
;
;Data line
S TCNT=TCNT+1,@TMP@(ACNT,TCNT)=$S($D(CHG(P)):CHG(P),1:F)_": "
S @TMP@(ACNT,TCNT)=@TMP@(ACNT,TCNT)_$S($P(VIEW(P),U)]"":$P(VIEW(P),U),$P(VIEW(P),U,2)=1:"<Value Deleted>",1:"")
;
;Clear delete flag
S:$P(VIEW(P),U,2)=1 VIEW(P)=$P(VIEW(P),U)
;
Q
;
QUAL(IEN) ;Get any qualifiers for this problem
NEW AIEN,IEN2,BY,WHEN,X,FNUM,Q,FIRST
I $D(^AUPNPROB(IEN,13))!($D(^AUPNPROB(IEN,17)))!($D(^AUPNPROB(IEN,18))) D SV("","QUALIFIERS")
F X=13,17,18 D
. S FIRST=0
. S FNUM=$S(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
. S IEN2=0 F S IEN2=$O(^AUPNPROB(IEN,X,IEN2)) Q:'+IEN2 D
.. S AIEN=IEN2_","_IEN_","
.. S Q=$$GET1^DIQ(FNUM,AIEN,.01)
.. ;
.. ;Skip Qualifier Attributes entry
.. I X=13,Q=246112005 Q
.. I X=18,Q=263502005 Q
.. ;
.. ;Print header
.. I FIRST=0 D
... I X=13 D SV(),SV("","Severity:")
... I X=18 D SV(),SV("","Clinical Course:")
... S FIRST=1
.. ;
.. ;Display the entry
.. S Q=$$CONCEPT^BGOPAUD(Q)
.. D SV("",Q)
.. I X=13 D
... S BY=$$GET1^DIQ(FNUM,AIEN,.02)
... S WHEN=$$GET1^DIQ(FNUM,AIEN,.03)
... D SV("","Entered by: "_BY_" On: "_WHEN)
Q
ICD(IEN) ;Get any additional ICD codes for this problem
N AIEN,IEN2
I $D(^AUPNPROB(IEN,12)) D ADD2(" Additional ICD Codes")
S IEN2=0 F S IEN2=$O(^AUPNPROB(IEN,12,IEN2)) Q:'+IEN2 D
.S AIEN=IEN2_","_IEN_","
.D ADD2($$GET1^DIQ(9000011.12,AIEN,.01))
Q
ADD1(TXT,LBL) ;
;S CNT=CNT+1 S @RET@(CNT)=$S($D(LBL):$$LJ^XLFSTR(LBL,20),1:"")_$G(TXT),LBL=""
Q
ADD2(TXT) ;
;S CNT=CNT+1 S @RET@(CNT)=TXT
Q
BJPNPBDT ;GDIT/HS/BEE-Prenatal Care Module - Retrieve Detail History ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;;Feb 24, 2015;Build 63
+2 ;
+3 QUIT
+4 ;
DET(DATA,PIP) ;EP - BJPN PROBLEM DETAIL
+1 ;
+2 ;This RPC returns the problem detail for a Problem entry (including past deletes)
+3 ;
+4 ;Input:
+5 ; PIP - Pointer to Prenatal Problem file entry
+6 ;
+7 NEW UID,II,TMP,PRBIEN,RET,VIEW,TCNT,ACNT,LINE,TMP1
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNPBDT",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET TMP=$NAME(^TMP("BJPNPDT1",UID))
+15 KILL @TMP
+16 SET RET=$NAME(^TMP("BJPNPDET",UID))
+17 KILL @RET
+18 ;
+19 SET $PIECE(LINE,"-",60)="-"
+20 ;
+21 SET II=0
+22 ;NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNPBDT D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
+23 ;
+24 ;Define Header
+25 SET @DATA@(II)="T01024REPORT_TEXT"_$CHAR(30)
+26 ;
+27 IF $GET(PIP)=""
SET BMXSEC="INVALID PIP IEN"
GOTO XDET
+28 ;
+29 ;Get the IPL pointer
+30 SET PRBIEN=$$GET1^DIQ(90680.01,PIP_",",.1,"I")
IF PRBIEN=""
SET BMXSEC="Invalid IPL pointer in PIP entry"
GOTO XDET
+31 ;
+32 ;Retrieve the audit history
+33 DO ACOMP^BJPNFAUD(.RET,PIP,PRBIEN)
+34 ;
+35 ;Compile the information by date/time and user
+36 SET ADT=""
SET (ACNT,TCNT)=0
FOR
SET ADT=$ORDER(@RET@(ADT))
IF ADT=""
QUIT
SET USER=""
FOR
SET USER=$ORDER(@RET@(ADT,USER))
IF USER=""
QUIT
Begin DoDot:1
+37 ;
+38 NEW N,V,G,CHG
+39 ;
+40 ;Update event counter
+41 SET ACNT=ACNT+1
+42 DO SV("",LINE)
+43 ;
+44 SET G=$NAME(@RET@(ADT,USER))
+45 ;
+46 ;See if the last one
+47 IF '$$NEXT(.RET,ADT,USER)
Begin DoDot:2
+48 DO SV("","CURRENT PIP/IPL DISPLAY")
+49 DO SV()
End DoDot:2
+50 ;
+51 ;IPL Change Header
+52 DO SV("","IPL Listing:")
+53 DO SV()
+54 ;
+55 ;IPL Add/Edit
+56 IF $DATA(@G@("DIAGNOSIS"))
Begin DoDot:2
+57 SET N=@G@("DIAGNOSIS")
+58 IF $PIECE(N,U)=""
SET VIEW("IPL.01")=$PIECE(N,U,2)
SET CHG("IPL.01")="Problem diagnosis added to IPL"
QUIT
+59 SET VIEW("IPL.01")=$PIECE(N,U,2)
SET CHG("IPL.01")="IPL Problem diagnosis changed to"
End DoDot:2
+60 IF $DATA(VIEW("IPL.01"))
DO SV("IPL.01","Problem diagnosis")
+61 ;
+62 ;Provider Text
+63 IF $DATA(@G@("PROVIDER NARRATIVE"))
Begin DoDot:2
+64 SET N=$PIECE(@G@("PROVIDER NARRATIVE"),U,2)
+65 SET VIEW("IPL.05")=N_U_$SELECT(N]"":"",1:"^1")
+66 SET CHG("IPL.05")="Provider Narrative set to"
End DoDot:2
+67 IF $DATA(VIEW("IPL.05"))
DO SV("IPL.05","Provider Narrative")
+68 ;
+69 ;IPL Status
+70 IF $DATA(@G@("STATUS"))
Begin DoDot:2
+71 SET N=$PIECE(@G@("STATUS"),U,2)
+72 SET VIEW("IPL.12")=N_U_$SELECT(N]"":"",1:"^1")
+73 SET CHG("IPL.12")="IPL Status set to"
End DoDot:2
+74 IF $DATA(VIEW("IPL.12"))
DO SV("IPL.12","IPL Status")
+75 ;
+76 ;IPL Class
+77 IF $DATA(@G@("CLASS"))
Begin DoDot:2
+78 SET N=$PIECE(@G@("CLASS"),U,2)
+79 SET VIEW("IPL.04")=N_$SELECT(N]"":"",1:"^1")
+80 SET CHG("IPL.04")="IPL Class set to"
End DoDot:2
+81 IF $DATA(VIEW("IPL.04"))
DO SV("IPL.04","IPL Class")
+82 ;
+83 ;Date of Onset
+84 IF $DATA(@G@("DATE OF ONSET"))
Begin DoDot:2
+85 SET N=$PIECE(@G@("DATE OF ONSET"),U,2)
+86 SET VIEW("IPL.13")=N_$SELECT(N]"":"",1:"^1")
+87 SET CHG("IPL.13")="IPL Date of Onset set to"
End DoDot:2
+88 IF $DATA(VIEW("IPL.13"))
DO SV("IPL.13","IPL Date of Onset")
+89 ;
+90 ;IPL PIP
+91 IF $DATA(@G@("PIP"))
Begin DoDot:2
+92 SET N=$PIECE(@G@("PIP"),U,2)
+93 SET VIEW("IPL.19")=N_$SELECT(N]"":"",1:"^1")
+94 SET CHG("IPL.19")="IPL PIP set to"
End DoDot:2
+95 IF $DATA(VIEW("IPL.19"))
DO SV("IPL.19","IPL PIP")
+96 ;
+97 ;POV - Ambulatory
+98 IF $DATA(@G@("USE AS POV (VISIT)"))
Begin DoDot:2
+99 ;
+100 ;Determine if an add or remove POV
+101 SET N=@G@("USE AS POV (VISIT)")
+102 ;
+103 ;Add
+104 IF $PIECE(N,U,2)]""
Begin DoDot:3
+105 SET VIEW("APOV."_$PIECE(N,U,3))=$PIECE(N,U,2)
+106 SET CHG("APOV."_$PIECE(N,U,3))="Problem set as POV for visit"
End DoDot:3
+107 ;
+108 ;Remove
+109 IF $PIECE(N,U,2)=""
Begin DoDot:3
+110 SET VIEW("APOV."_$PIECE(N,U,3))=$PIECE(N,U)_U_1
+111 SET CHG("APOV."_$PIECE(N,U,3))="Problem removed as POV for visit"
End DoDot:3
End DoDot:2
+112 IF $ORDER(VIEW("APOV."))["APOV."
Begin DoDot:2
+113 NEW POV
+114 DO SV()
+115 SET POV="APOV."
FOR
SET POV=$ORDER(VIEW(POV))
IF POV'["APOV."
QUIT
Begin DoDot:3
+116 IF $PIECE(VIEW(POV),U,2)'=1
DO SV(POV,"Problem used as POV for visit")
QUIT
+117 SET VIEW(POV)=$PIECE(VIEW(POV),U)
DO SV(POV,"")
+118 KILL VIEW(POV)
End DoDot:3
End DoDot:2
+119 ;
+120 ;POV - Inpatient
+121 IF $DATA(@G@("USED FOR INPATIENT"))
Begin DoDot:2
+122 ;
+123 ;Determine if an add or remove POV
+124 SET N=@G@("USED FOR INPATIENT")
+125 ;
+126 ;Add
+127 IF $PIECE(N,U,2)]""
Begin DoDot:3
+128 SET VIEW("IPOV."_$PIECE(N,U,3))=$PIECE(N,U,2)
+129 SET CHG("IPOV."_$PIECE(N,U,3))="Problem set as POV for inpatient visit"
End DoDot:3
+130 ;
+131 ;Remove
+132 IF $PIECE(N,U,2)=""
Begin DoDot:3
+133 SET VIEW("IPOV."_$PIECE(N,U,3))=$PIECE(N,U)_U_1
+134 SET CHG("IPOV."_$PIECE(N,U,3))="Problem removed as POV for inpatient visit"
End DoDot:3
End DoDot:2
+135 IF $ORDER(VIEW("IPOV."))["IPOV."
Begin DoDot:2
+136 NEW POV
+137 DO SV()
+138 SET POV="IPOV."
FOR
SET POV=$ORDER(VIEW(POV))
IF POV'["IPOV."
QUIT
Begin DoDot:3
+139 IF $PIECE(VIEW(POV),U,2)'=1
DO SV(POV,"Problem used as POV for inpatient visit")
QUIT
+140 SET VIEW(POV)=$PIECE(VIEW(POV),U)
DO SV(POV,"")
+141 KILL VIEW(POV)
End DoDot:3
End DoDot:2
+142 ;
+143 ;Severity Qualifier
+144 IF $DATA(@G@("SEVERITY"))
Begin DoDot:2
+145 SET N=$PIECE(@G@("SEVERITY"),U,2)
+146 SET VIEW("IPL.SEV")=$PIECE($$CONC^BSTSAPI(N_"^^^1"),U,4)_$SELECT(N]"":"",1:"^1")
+147 SET CHG("IPL.SEV")="Severity Qualifier set to"
End DoDot:2
+148 IF $DATA(VIEW("IPL.SEV"))
DO SV("IPL.SEV","Severity Qualifier")
+149 ;
+150 ;PIP Change Header
+151 DO SV()
+152 DO SV("","PIP Listing:")
+153 DO SV()
+154 ;
+155 ;PIP Add/Edit
+156 IF $DATA(@G@("PLACEHOLDER FIELD"))
DO SV("","Problem Added to PIP")
+157 ;
+158 ;PIP Status
+159 IF $DATA(@G@("CURRENT STATUS"))
Begin DoDot:2
+160 SET N=$PIECE(@G@("CURRENT STATUS"),U,2)
+161 SET VIEW("PIP.08")=N_$SELECT(N]"":"",1:"^1")
+162 SET CHG("PIP.08")="PIP Status set to"
End DoDot:2
+163 IF $DATA(VIEW("PIP.08"))
DO SV("PIP.08","PIP Status")
+164 ;
+165 ;PIP Scope
+166 IF $DATA(@G@("CURRENT SCOPE"))
Begin DoDot:2
+167 SET N=$PIECE(@G@("CURRENT SCOPE"),U,2)
+168 SET VIEW("PIP.07")=N_$SELECT(N]"":"",1:"^1")
+169 SET CHG("PIP.07")="PIP Scope set to"
End DoDot:2
+170 IF $DATA(VIEW("PIP.07"))
DO SV("PIP.07","PIP Scope")
+171 ;
+172 ;PIP Priority
+173 IF $DATA(@G@("CURRENT PRIORITY"))
Begin DoDot:2
+174 SET N=$PIECE(@G@("CURRENT PRIORITY"),U,2)
+175 SET VIEW("PIP.06")=N_$SELECT(N]"":"",1:"^1")
+176 SET CHG("PIP.06")="PIP Priority set to"
End DoDot:2
+177 IF $DATA(VIEW("PIP.06"))
DO SV("PIP.06","PIP Priority")
+178 ;
+179 ;PIP Definitive EDD
+180 IF $DATA(@G@("CURRENT DEFINITIVE EDD"))
Begin DoDot:2
+181 SET N=$PIECE(@G@("CURRENT DEFINITIVE EDD"),U,2)
+182 SET VIEW("PIP.09")=N_$SELECT(N]"":"",1:"^1")
+183 SET CHG("PIP.09")="PIP Problem Definitive EDD set to"
End DoDot:2
+184 IF $DATA(VIEW("PIP.09"))
DO SV("PIP.09","PIP Problem Definitive EDD")
+185 ;
+186 ;PIP
+187 IF $DATA(@G@("PIPF"))
Begin DoDot:2
+188 SET N=$PIECE(@G@("PIPF"),U,2)
+189 SET VIEW("PIP.5.02")=N_$SELECT(N]"":"",1:"^1")
+190 SET CHG("PIP.5.02")="PIP Flag set to"
End DoDot:2
+191 IF $DATA(VIEW("PIP.5.02"))
DO SV("PIP.5.02","PIP Flag")
+192 ;
+193 ;PIP Date
+194 IF $DATA(@G@("PIP DATE"))
Begin DoDot:2
+195 SET N=$PIECE(@G@("PIP DATE"),U,2)
+196 SET VIEW("PIP.5.01")=N_$SELECT(N]"":"",1:"^1")
+197 SET CHG("PIP.5.01")="PIP Flag Date set to"
End DoDot:2
+198 IF $DATA(VIEW("PIP.5.01"))
DO SV("PIP.5.01","PIP Flag Date")
+199 ;
+200 ;PIP User
+201 IF $DATA(@G@("PIP USER"))
Begin DoDot:2
+202 SET N=$PIECE(@G@("PIP USER"),U,2)
+203 SET VIEW("PIP.5.03")=N_$SELECT(N]"":"",1:"^1")
+204 SET CHG("PIP.5.03")="PIP Flag User set to"
End DoDot:2
+205 IF $DATA(VIEW("PIP.5.03"))
DO SV("PIP.5.03","PIP Flag User")
+206 ;
+207 ;Goal Notes
+208 IF $ORDER(@G@("GOAL."))["GOAL."
Begin DoDot:2
+209 NEW GENT
+210 ;
+211 ;Loop through each entry
+212 SET GENT="GOAL."
FOR
SET GENT=$ORDER(@G@(GENT))
IF GENT'["GOAL."
QUIT
Begin DoDot:3
+213 ;
+214 NEW CSTS,XSTS,N,NIEN
+215 SET CSTS=$PIECE(GENT,".",2)
+216 SET XSTS=@G@(GENT)
+217 SET N=""
SET NIEN=0
FOR
SET NIEN=$ORDER(^AUPNCPL(CSTS,12,NIEN))
IF '+NIEN
QUIT
Begin DoDot:4
+218 SET N=N_$SELECT(N]"":$CHAR(13)_$CHAR(10),1:"")_$GET(^AUPNCPL(CSTS,12,NIEN,0))
End DoDot:4
+219 SET VIEW("GOAL."_CSTS_".A")=XSTS_$SELECT(XSTS="ACTIVE":"",1:"^2")
+220 SET VIEW("GOAL."_CSTS_".N")=N_$SELECT(XSTS="ACTIVE":"",1:"^2")
+221 SET CHG("GOAL."_CSTS_".A")="Goal Note status set to"
+222 IF XSTS="ACTIVE"
SET CHG("GOAL."_CSTS_".N")="Goal Note set to"
End DoDot:3
End DoDot:2
+223 IF $ORDER(VIEW("GOAL."))["GOAL."
Begin DoDot:2
+224 DO SV()
DO SV("","GOAL NOTES")
DO SV()
+225 NEW GENT
+226 SET GENT="GOAL."
FOR
SET GENT=$ORDER(VIEW(GENT))
IF GENT'["GOAL."
QUIT
Begin DoDot:3
+227 NEW STS,NOTE
+228 IF GENT[".A"
DO SV(GENT,"Goal Note status")
+229 IF GENT[".N"
DO SV(GENT,"Goal Note")
DO SV()
+230 IF $PIECE(VIEW(GENT),U,2)=2
KILL VIEW(GENT)
End DoDot:3
End DoDot:2
+231 ;
+232 ;Care Plans
+233 IF $ORDER(@G@("CARE."))["CARE."
Begin DoDot:2
+234 NEW GENT
+235 ;
+236 ;Loop through each entry
+237 SET GENT="CARE."
FOR
SET GENT=$ORDER(@G@(GENT))
IF GENT'["CARE."
QUIT
Begin DoDot:3
+238 ;
+239 NEW CSTS,XSTS,N,NIEN
+240 SET CSTS=$PIECE(GENT,".",2)
+241 SET XSTS=@G@(GENT)
+242 SET N=""
SET NIEN=0
FOR
SET NIEN=$ORDER(^AUPNCPL(CSTS,12,NIEN))
IF '+NIEN
QUIT
Begin DoDot:4
+243 SET N=N_$SELECT(N]"":$CHAR(13)_$CHAR(10),1:"")_$GET(^AUPNCPL(CSTS,12,NIEN,0))
End DoDot:4
+244 SET VIEW("CARE."_CSTS_".A")=XSTS_$SELECT(XSTS="ACTIVE":"",1:"^2")
+245 SET VIEW("CARE."_CSTS_".N")=N_$SELECT(XSTS="ACTIVE":"",1:"^2")
+246 SET CHG("CARE."_CSTS_".A")="Care Plan status set to"
+247 IF XSTS="ACTIVE"
SET CHG("CARE."_CSTS_".N")="Care Plan set to"
End DoDot:3
End DoDot:2
+248 IF $ORDER(VIEW("CARE."))["CARE."
Begin DoDot:2
+249 DO SV()
DO SV("","CARE PLANS")
DO SV()
+250 NEW GENT
+251 SET GENT="CARE."
FOR
SET GENT=$ORDER(VIEW(GENT))
IF GENT'["CARE."
QUIT
Begin DoDot:3
+252 NEW STS,NOTE
+253 IF GENT[".A"
DO SV(GENT,"Care Plan status")
+254 IF GENT[".N"
DO SV(GENT,"Care Plan")
DO SV()
+255 IF $PIECE(VIEW(GENT),U,2)=2
KILL VIEW(GENT)
End DoDot:3
End DoDot:2
+256 ;
+257 ;Visit Instructions
+258 IF $ORDER(@G@("VINS."))["VINS."
Begin DoDot:2
+259 NEW VENT
+260 ;
+261 ;Loop through each entry
+262 SET VENT="VINS."
FOR
SET VENT=$ORDER(@G@(VENT))
IF VENT'["VINS."
QUIT
Begin DoDot:3
+263 ;
+264 NEW CSTS,XSTS,N,NIEN,VDT
+265 SET CSTS=$PIECE(VENT,".",2)
+266 SET N=""
SET NIEN=0
FOR
SET NIEN=$ORDER(^AUPNVVI(CSTS,11,NIEN))
IF '+NIEN
QUIT
Begin DoDot:4
+267 SET N=N_$SELECT(N]"":$CHAR(13)_$CHAR(10),1:"")_$GET(^AUPNVVI(CSTS,11,NIEN,0))
End DoDot:4
+268 SET VIEW("VINS."_CSTS_".N")=N
+269 SET VIEW("VINS."_CSTS_".D")=$$GET1^DIQ(9000010.58,CSTS_",",.03,"E")
+270 SET CHG("VINS."_CSTS_".N")="Visit Instruction set to"
End DoDot:3
End DoDot:2
+271 IF $ORDER(VIEW("VINS."))["VINS."
Begin DoDot:2
+272 DO SV()
DO SV("","VISIT INSTRUCTIONS")
DO SV()
+273 NEW VENT
+274 SET VENT="VINS."
FOR
SET VENT=$ORDER(VIEW(VENT))
IF VENT'["VINS."
QUIT
Begin DoDot:3
+275 IF VENT[".D"
DO SV(VENT,"Visit Date")
+276 IF VENT[".N"
DO SV(VENT,"Visit Instruction")
DO SV()
End DoDot:3
End DoDot:2
+277 ;
+278 ;Treatment Regimen
+279 IF $ORDER(@G@("VTR."))["VTR."
Begin DoDot:2
+280 NEW VENT
+281 ;
+282 ;Loop through each entry
+283 SET VENT="VTR."
FOR
SET VENT=$ORDER(@G@(VENT))
IF VENT'["VTR."
QUIT
Begin DoDot:3
+284 ;
+285 NEW CSTS,XSTS,N,NIEN,VDT
+286 SET CSTS=$PIECE(VENT,".",2)
+287 SET N=$$GET1^DIQ(9000010.61,CSTS_",",.01,"I")
IF N=""
QUIT
+288 SET N=$PIECE($$CONC^BSTSAPI(N_"^^^1"),U,4)
IF N=""
QUIT
+289 SET VIEW("VTR."_CSTS_".N")=N
+290 SET VIEW("VTR."_CSTS_".D")=$$GET1^DIQ(9000010.61,CSTS_",",.03,"E")
+291 SET CHG("VTR."_CSTS_".N")="Treatment Regimen set to"
End DoDot:3
End DoDot:2
+292 IF $ORDER(VIEW("VTR."))["VTR."
Begin DoDot:2
+293 DO SV()
DO SV("","TREATMENT REGIMEN")
DO SV()
+294 NEW VENT
+295 SET VENT="VTR."
FOR
SET VENT=$ORDER(VIEW(VENT))
IF VENT'["VTR."
QUIT
Begin DoDot:3
+296 IF VENT[".D"
DO SV(VENT,"Visit Date")
+297 IF VENT[".N"
DO SV(VENT,"Treatment Regimen")
DO SV()
End DoDot:3
End DoDot:2
+298 ;
+299 ;Education
+300 IF $ORDER(@G@("VEDU."))["VEDU."
Begin DoDot:2
+301 NEW VENT
+302 ;
+303 ;Loop through each entry
+304 SET VENT="VEDU."
FOR
SET VENT=$ORDER(@G@(VENT))
IF VENT'["VEDU."
QUIT
Begin DoDot:3
+305 ;
+306 NEW CSTS,XSTS,N,NIEN,VDT,SCNT,SMD,RED,TIM
+307 SET CSTS=$PIECE(VENT,".",2)
SET SCNT=0
+308 SET N=$$GET1^DIQ(9000010.16,CSTS_",",.01,"E")
IF N=""
QUIT
+309 ;S N=$P($$CONC^BSTSAPI(N_"^^^1"),U,4) Q:N=""
+310 SET VIEW("VEDU."_CSTS_".N")=N
+311 SET VIEW("VEDU."_CSTS_".D")=$$GET1^DIQ(9000010.16,CSTS_",",.03,"E")
+312 SET CHG("VEDU."_CSTS_".N")="Patient Education set to"
+313 ;
+314 ;Snomed
+315 SET SMD=$$GET1^DIQ(9000010.16,CSTS_",",1301,"I")
IF SMD]""
Begin DoDot:4
+316 SET SCNT=SCNT+1
+317 SET CHG("VEDU."_CSTS_".S1."_SCNT)="SNOMED Topic set to"
+318 SET VIEW("VEDU."_CSTS_".S1."_SCNT)=$PIECE($$CONC^BSTSAPI(SMD_"^^^1"),U,4)
End DoDot:4
+319 SET SMD=""
FOR
SET SMD=$ORDER(^AUPNVPED(CSTS,26,"B",SMD))
IF SMD=""
QUIT
Begin DoDot:4
+320 SET SCNT=SCNT+1
+321 SET CHG("VEDU."_CSTS_".S2."_SCNT)="SNOMED set to"
+322 SET VIEW("VEDU."_CSTS_".S2."_SCNT)=$PIECE($$CONC^BSTSAPI(SMD_"^^^1"),U,4)
End DoDot:4
+323 ;
+324 ;Readiness to learn
+325 SET RED=$$GET1^DIQ(9000010.16,CSTS_",",1102,"E")
IF RED]""
Begin DoDot:4
+326 SET CHG("VEDU."_CSTS_".R1")="Readiness to learn set to"
+327 SET VIEW("VEDU."_CSTS_".R1")=RED
End DoDot:4
+328 ;
+329 ;Length of Educ (Minutes)
+330 SET TIM=$$GET1^DIQ(9000010.16,CSTS_",",.08,"I")
IF TIM]""
Begin DoDot:4
+331 SET CHG("VEDU."_CSTS_".R2")="Length of education (minutes) set to"
+332 SET VIEW("VEDU."_CSTS_".R2")=TIM
End DoDot:4
End DoDot:3
End DoDot:2
+333 IF $ORDER(VIEW("VEDU."))["VEDU."
Begin DoDot:2
+334 DO SV()
DO SV("","PATIENT EDUCATION")
+335 NEW VENT
+336 SET VENT="VEDU."
FOR
SET VENT=$ORDER(VIEW(VENT))
IF VENT'["VEDU."
QUIT
Begin DoDot:3
+337 IF VENT[".D"
DO SV()
DO SV(VENT,"Visit Date")
+338 IF VENT[".N"
DO SV(VENT,"Patient Education")
+339 IF VENT[".S1"
DO SV(VENT,"SNOMED Topic")
+340 IF VENT[".S2"
DO SV(VENT,"SNOMED")
+341 IF VENT[".R2"
DO SV(VENT,"Length of education (minutes)")
+342 IF VENT[".R1"
DO SV(VENT,"Readiness to learn")
End DoDot:3
End DoDot:2
+343 ;
+344 ;Tack on Change on/by
+345 DO SV()
+346 DO SV("","Changes made on: "_$$FMTE^BJPNPRL(ADT))
+347 DO SV("","Changes made by: "_$$GET1^DIQ(200,USER_",",".01","E"))
+348 DO SV()
DO SV()
+349 ;
+350 ;Display current information if this is the last entry
+351 ;
+352 ;There is another entry
+353 IF $$NEXT(.RET,ADT,USER)
QUIT
+354 ;
+355 ;Qualifiers
+356 DO QUAL(PRBIEN)
+357 ;
+358 ;See if the last one
+359 IF '$$NEXT(.RET,ADT,USER)
Begin DoDot:2
+360 DO SV()
DO SV("",LINE)
+361 DO SV("","PIP/IPL ACTIVITY HISTORY")
+362 DO SV()
End DoDot:2
End DoDot:1
+363 ;
+364 SET ACNT=""
FOR
SET ACNT=$ORDER(@TMP@(ACNT),-1)
IF ACNT=""
QUIT
Begin DoDot:1
+365 SET TCNT=""
FOR
SET TCNT=$ORDER(@TMP@(ACNT,TCNT))
IF TCNT=""
QUIT
Begin DoDot:2
+366 SET II=II+1
SET @DATA@(II)=@TMP@(ACNT,TCNT)_$CHAR(13)_$CHAR(10)
End DoDot:2
End DoDot:1
+367 IF II>0
SET @DATA@(II)=$GET(@DATA@(II))_$CHAR(30)
+368 ;
XDET IF $GET(RET)]""
KILL @RET
+1 IF $GET(TMP)]""
KILL @TMP
+2 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+3 QUIT
+4 ;
NEXT(RET,ADT,USER) ;Check if there is an entry after this one
+1 ;
+2 ;First see if there is another user entry
+3 IF $ORDER(@RET@(ADT,USER))]""
QUIT 1
+4 ;
+5 ;Now see if there is another date
+6 IF $ORDER(@RET@(ADT))]""
QUIT 1
+7 ;
+8 QUIT 0
+9 ;
SV(P,F) ;Increment the scratch entry
+1 ;
+2 SET P=$GET(P)
SET F=$GET(F)
+3 ;
+4 ;Skip a line
+5 IF P=""
IF F=""
SET TCNT=TCNT+1
SET @TMP@(ACNT,TCNT)=""
QUIT
+6 ;
+7 ;Non-data line
+8 IF P=""
IF F]""
SET TCNT=TCNT+1
SET @TMP@(ACNT,TCNT)=F
QUIT
+9 ;
+10 ;Data line
+11 SET TCNT=TCNT+1
SET @TMP@(ACNT,TCNT)=$SELECT($DATA(CHG(P)):CHG(P),1:F)_": "
+12 SET @TMP@(ACNT,TCNT)=@TMP@(ACNT,TCNT)_$SELECT($PIECE(VIEW(P),U)]"":$PIECE(VIEW(P),U),$PIECE(VIEW(P),U,2)=1:"<Value Deleted>",1:"")
+13 ;
+14 ;Clear delete flag
+15 IF $PIECE(VIEW(P),U,2)=1
SET VIEW(P)=$PIECE(VIEW(P),U)
+16 ;
+17 QUIT
+18 ;
QUAL(IEN) ;Get any qualifiers for this problem
+1 NEW AIEN,IEN2,BY,WHEN,X,FNUM,Q,FIRST
+2 IF $DATA(^AUPNPROB(IEN,13))!($DATA(^AUPNPROB(IEN,17)))!($DATA(^AUPNPROB(IEN,18)))
DO SV("","QUALIFIERS")
+3 FOR X=13,17,18
Begin DoDot:1
+4 SET FIRST=0
+5 SET FNUM=$SELECT(X=13:9000011.13,X=17:9000011.17,X=18:9000011.18)
+6 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNPROB(IEN,X,IEN2))
IF '+IEN2
QUIT
Begin DoDot:2
+7 SET AIEN=IEN2_","_IEN_","
+8 SET Q=$$GET1^DIQ(FNUM,AIEN,.01)
+9 ;
+10 ;Skip Qualifier Attributes entry
+11 IF X=13
IF Q=246112005
QUIT
+12 IF X=18
IF Q=263502005
QUIT
+13 ;
+14 ;Print header
+15 IF FIRST=0
Begin DoDot:3
+16 IF X=13
DO SV()
DO SV("","Severity:")
+17 IF X=18
DO SV()
DO SV("","Clinical Course:")
+18 SET FIRST=1
End DoDot:3
+19 ;
+20 ;Display the entry
+21 SET Q=$$CONCEPT^BGOPAUD(Q)
+22 DO SV("",Q)
+23 IF X=13
Begin DoDot:3
+24 SET BY=$$GET1^DIQ(FNUM,AIEN,.02)
+25 SET WHEN=$$GET1^DIQ(FNUM,AIEN,.03)
+26 DO SV("","Entered by: "_BY_" On: "_WHEN)
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
ICD(IEN) ;Get any additional ICD codes for this problem
+1 NEW AIEN,IEN2
+2 IF $DATA(^AUPNPROB(IEN,12))
DO ADD2(" Additional ICD Codes")
+3 SET IEN2=0
FOR
SET IEN2=$ORDER(^AUPNPROB(IEN,12,IEN2))
IF '+IEN2
QUIT
Begin DoDot:1
+4 SET AIEN=IEN2_","_IEN_","
+5 DO ADD2($$GET1^DIQ(9000011.12,AIEN,.01))
End DoDot:1
+6 QUIT
ADD1(TXT,LBL) ;
+1 ;S CNT=CNT+1 S @RET@(CNT)=$S($D(LBL):$$LJ^XLFSTR(LBL,20),1:"")_$G(TXT),LBL=""
+2 QUIT
ADD2(TXT) ;
+1 ;S CNT=CNT+1 S @RET@(CNT)=TXT
+2 QUIT
