- VPRDSR ;SLC/MKB -- Surgical Procedures ;8/2/11 15:29
- ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; External References DBIA#
- ; ------------------- -----
- ; ^SRF(130 5675
- ; ^SRO(136 4872
- ; DIQ 2056
- ; ICPTCOD 1995
- ; ICPTMOD 1996
- ; SROESTV 3533
- ;
- ; ------------ Get surgery(ies) from VistA ------------
- ;
- EN(DFN,BEG,END,MAX,ID) ; -- find patient's surgeries
- N VPRN,VPRCNT,VPRITM,VPRY
- S DFN=+$G(DFN) Q:DFN<1
- S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
- ;
- ; get one surgery
- I $G(ID) D EN1(ID,.VPRITM),XML(.VPRITM) G ENQ
- ;
- ; get all surgeries
- Q:'$L($T(LIST^SROESTV))
- N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
- D LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
- S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D
- . K VPRITM D ONE(VPRN,.VPRITM)
- . I $D(VPRITM) D XML(.VPRITM)
- K @VPRY
- ENQ ; end
- K ^TMP("VPRTEXT",$J)
- Q
- ;
- ONE(NUM,SURG) ; -- return a surgery in SURG("attribute")=value
- ; Expects DFN, @VPRY@(NUM) from LIST^SROESTV
- N IEN,VPRX,X,Y,I,VPRMOD,VPROTH
- K SURG,^TMP("VPRTEXT",$J)
- S VPRX=$G(@VPRY@(NUM)),IEN=+$P(VPRX,U) Q:IEN<1
- S SURG("id")=IEN,X=$P(VPRX,U,2),SURG("status")="COMPLETED"
- I X?1"* Aborted * ".E S X=$E(X,13,999),SURG("status")="ABORTED"
- S SURG("name")=X,SURG("dateTime")=$P(VPRX,U,3)
- S X=$P(VPRX,U,4) S:X SURG("provider")=$TR(X,";","^")_U_$$PROVSPC^VPRD(+X)
- S X=$$GET1^DIQ(130,IEN_",",50,"I"),SURG("facility")=$$FAC^VPRD(X)
- S SURG("encounter")=$$GET1^DIQ(130,IEN_",",.015,"I")
- S X=$$GET1^DIQ(136,IEN_",",.02,"I") I X D
- . S SURG("type")=$$CPT(X)
- . D GETS^DIQ(136,IEN_",","1*","I","VPRMOD") ;CPT modifiers
- . S I="" F S I=$O(VPRMOD(136.01,I)) Q:I="" D
- .. S X=+$G(VPRMOD(136.01,I,.01,"I")),Y=$$MOD^ICPTMOD(X,"I")
- .. S SURG("modifier",+I)=$P(Y,U,2,3)
- D GETS^DIQ(136,IEN_",","3*","I","VPROTH") ;other procedures
- S I="" F S I=$O(VPROTH(136.03,I)) Q:I="" D
- . S X=+$G(VPROTH(136.03,I,.01,"I")) Q:'X
- . S SURG("otherProcedure",+I)=$$CPT(X)
- S I=0 F S I=$O(@VPRY@(NUM,I)) Q:I<1 S X=$G(@VPRY@(NUM,I)) I X D
- . S Y=$$INFO^VPRDTIU(+X) Q:Y<1 ;draft or retracted
- . S SURG("document",I)=Y
- . S:$G(VPRTEXT) SURG("document",I,"content")=$$TEXT^VPRDTIU(+X)
- . I Y["OPERATION REPORT"!(Y["PROCEDURE REPORT") S SURG("opReport")=Y
- S SURG("category")="SR"
- Q
- ;
- EN1(IEN,SURG) ; -- return a surgery in SURG("attribute")=value
- N VPRX,VPRY,X,Y,I,VPRMOD,VPROTH,SHOWADD
- K SURG,^TMP("VPRTEXT",$J)
- S SHOWADD=1 ;to omit leading '+' with note titles
- D ONE^SROESTV("VPRY",IEN) S VPRX=$G(VPRY(IEN)) Q:VPRX=""
- S SURG("id")=IEN,X=$P(VPRX,U,2),SURG("status")="COMPLETED"
- I X?1"* Aborted * ".E S X=$E(X,13,999),SURG("status")="ABORTED"
- S SURG("name")=X,SURG("dateTime")=$P(VPRX,U,3)
- S X=$P(VPRX,U,4) S:X SURG("provider")=$TR(X,";","^")_U_$$PROVSPC^VPRD(+X)
- S X=$$GET1^DIQ(130,IEN_",",50,"I"),SURG("facility")=$$FAC^VPRD(X)
- S SURG("encounter")=$$GET1^DIQ(130,IEN_",",.015,"I")
- S X=$$GET1^DIQ(136,IEN_",",.02,"I") I X D
- . S SURG("type")=$$CPT(X)
- . D GETS^DIQ(136,IEN_",","1*","I","VPRMOD") ;CPT modifiers
- . S I="" F S I=$O(VPRMOD(136.01,I)) Q:I="" D
- .. S X=+$G(VPRMOD(136.01,I,.01,"I")),Y=$$MOD^ICPTMOD(X,"I")
- .. S SURG("modifier",+I)=$P(Y,U,2,3)
- D GETS^DIQ(136,IEN_",","3*","I","VPROTH") ;other procedures
- S I="" F S I=$O(VPROTH(136.03,I)) Q:I="" D
- . S X=+$G(VPROTH(136.03,I,.01,"I")) Q:'X
- . S SURG("otherProcedure",+I)=$$CPT(X)
- S I=0 F S I=$O(VPRY(IEN,I)) Q:I<1 S X=$G(VPRY(IEN,I)) I X D
- . S Y=$$INFO^VPRDTIU(+X) Q:Y<1 ;draft or retracted
- . S SURG("document",I)=Y
- . S:$G(VPRTEXT) SURG("document",I,"content")=$$TEXT^VPRDTIU(+X)
- . I Y["OPERATION REPORT"!(Y["PROCEDURE REPORT") S SURG("opReport")=Y
- S SURG("category")="SR"
- Q
- ;
- CPT(IEN) ; -- return code^description for CPT code, or "^" if error
- N X0,VPRX,N,I,X,Y S IEN=+$G(IEN)
- S X0=$$CPT^ICPTCOD(IEN) I X0<0 Q "^"
- S Y=$P(X0,U,2,3) ;CPT Code^Short Name
- S N=$$CPTD^ICPTCOD($P(Y,U),"VPRX") ;CPT Description
- I N>0,$L($G(VPRX(1))) D
- . S X=$G(VPRX(1)),I=1
- . F S I=$O(VPRX(I)) Q:I<1 Q:VPRX(I)=" " S X=X_" "_VPRX(I)
- . S $P(Y,U,2)=X
- Q Y
- ;
- ; ------------ Return data to middle tier ------------
- ;
- XML(SURG) ; -- Return surgery as XML
- N ATT,X,Y,NAMES,I,J
- D ADD("<surgery>") S VPRTOTL=$G(VPRTOTL)+1
- S ATT="" F S ATT=$O(SURG(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
- . I $O(SURG(ATT,0)) D S Y="" Q ;multiples
- .. D ADD("<"_ATT_"s>")
- .. S I=0 F S I=$O(SURG(ATT,I)) Q:I<1 D
- ... S X=$G(SURG(ATT,I)),NAMES=""
- ... S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^vuid^Z",1:"code^name^Z")
- ... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
- ... S X=$G(SURG(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q
- ... S Y=Y_">" D ADD(Y)
- ... S Y="<content xml:space='preserve'>" D ADD(Y)
- ... S J=0 F S J=$O(@X@(J)) Q:J<1 S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)
- ... D ADD("</content>"),ADD("</"_ATT_">")
- .. D ADD("</"_ATT_"s>")
- . S X=$G(SURG(ATT)),Y="" Q:'$L(X)
- . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
- . S NAMES=$S(ATT="opReport":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,1:"code^name")_"^Z"
- . I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
- D ADD("</surgery>")
- Q
- ;
- LOOP() ; -- build sub-items string from NAMES and X
- N STR,P,TAG S STR=""
- F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
- Q STR
- ;
- ADD(X) ; -- Add a line @VPR@(n)=X
- S VPRI=$G(VPRI)+1
- S @VPR@(VPRI)=X
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDSR 5685 printed Feb 19, 2025@00:11:34 Page 2
- VPRDSR ;SLC/MKB -- Surgical Procedures ;8/2/11 15:29
- +1 ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; External References DBIA#
- +5 ; ------------------- -----
- +6 ; ^SRF(130 5675
- +7 ; ^SRO(136 4872
- +8 ; DIQ 2056
- +9 ; ICPTCOD 1995
- +10 ; ICPTMOD 1996
- +11 ; SROESTV 3533
- +12 ;
- +13 ; ------------ Get surgery(ies) from VistA ------------
- +14 ;
- EN(DFN,BEG,END,MAX,ID) ; -- find patient's surgeries
- +1 NEW VPRN,VPRCNT,VPRITM,VPRY
- +2 SET DFN=+$GET(DFN)
- if DFN<1
- QUIT
- +3 SET BEG=$GET(BEG,1410101)
- SET END=$GET(END,4141015)
- SET MAX=$GET(MAX,9999)
- +4 ;
- +5 ; get one surgery
- +6 IF $GET(ID)
- DO EN1(ID,.VPRITM)
- DO XML(.VPRITM)
- GOTO ENQ
- +7 ;
- +8 ; get all surgeries
- +9 if '$LENGTH($TEXT(LIST^SROESTV))
- QUIT
- +10 ;to omit leading '+' with note titles
- NEW SHOWADD
- SET SHOWADD=1
- +11 DO LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
- +12 SET VPRN=0
- FOR
- SET VPRN=$ORDER(@VPRY@(VPRN))
- if VPRN<1
- QUIT
- Begin DoDot:1
- +13 KILL VPRITM
- DO ONE(VPRN,.VPRITM)
- +14 IF $DATA(VPRITM)
- DO XML(.VPRITM)
- End DoDot:1
- +15 KILL @VPRY
- ENQ ; end
- +1 KILL ^TMP("VPRTEXT",$JOB)
- +2 QUIT
- +3 ;
- ONE(NUM,SURG) ; -- return a surgery in SURG("attribute")=value
- +1 ; Expects DFN, @VPRY@(NUM) from LIST^SROESTV
- +2 NEW IEN,VPRX,X,Y,I,VPRMOD,VPROTH
- +3 KILL SURG,^TMP("VPRTEXT",$JOB)
- +4 SET VPRX=$GET(@VPRY@(NUM))
- SET IEN=+$PIECE(VPRX,U)
- if IEN<1
- QUIT
- +5 SET SURG("id")=IEN
- SET X=$PIECE(VPRX,U,2)
- SET SURG("status")="COMPLETED"
- +6 IF X?1"* Aborted * ".E
- SET X=$EXTRACT(X,13,999)
- SET SURG("status")="ABORTED"
- +7 SET SURG("name")=X
- SET SURG("dateTime")=$PIECE(VPRX,U,3)
- +8 SET X=$PIECE(VPRX,U,4)
- if X
- SET SURG("provider")=$TRANSLATE(X,";","^")_U_$$PROVSPC^VPRD(+X)
- +9 SET X=$$GET1^DIQ(130,IEN_",",50,"I")
- SET SURG("facility")=$$FAC^VPRD(X)
- +10 SET SURG("encounter")=$$GET1^DIQ(130,IEN_",",.015,"I")
- +11 SET X=$$GET1^DIQ(136,IEN_",",.02,"I")
- IF X
- Begin DoDot:1
- +12 SET SURG("type")=$$CPT(X)
- +13 ;CPT modifiers
- DO GETS^DIQ(136,IEN_",","1*","I","VPRMOD")
- +14 SET I=""
- FOR
- SET I=$ORDER(VPRMOD(136.01,I))
- if I=""
- QUIT
- Begin DoDot:2
- +15 SET X=+$GET(VPRMOD(136.01,I,.01,"I"))
- SET Y=$$MOD^ICPTMOD(X,"I")
- +16 SET SURG("modifier",+I)=$PIECE(Y,U,2,3)
- End DoDot:2
- End DoDot:1
- +17 ;other procedures
- DO GETS^DIQ(136,IEN_",","3*","I","VPROTH")
- +18 SET I=""
- FOR
- SET I=$ORDER(VPROTH(136.03,I))
- if I=""
- QUIT
- Begin DoDot:1
- +19 SET X=+$GET(VPROTH(136.03,I,.01,"I"))
- if 'X
- QUIT
- +20 SET SURG("otherProcedure",+I)=$$CPT(X)
- End DoDot:1
- +21 SET I=0
- FOR
- SET I=$ORDER(@VPRY@(NUM,I))
- if I<1
- QUIT
- SET X=$GET(@VPRY@(NUM,I))
- IF X
- Begin DoDot:1
- +22 ;draft or retracted
- SET Y=$$INFO^VPRDTIU(+X)
- if Y<1
- QUIT
- +23 SET SURG("document",I)=Y
- +24 if $GET(VPRTEXT)
- SET SURG("document",I,"content")=$$TEXT^VPRDTIU(+X)
- +25 IF Y["OPERATION REPORT"!(Y["PROCEDURE REPORT")
- SET SURG("opReport")=Y
- End DoDot:1
- +26 SET SURG("category")="SR"
- +27 QUIT
- +28 ;
- EN1(IEN,SURG) ; -- return a surgery in SURG("attribute")=value
- +1 NEW VPRX,VPRY,X,Y,I,VPRMOD,VPROTH,SHOWADD
- +2 KILL SURG,^TMP("VPRTEXT",$JOB)
- +3 ;to omit leading '+' with note titles
- SET SHOWADD=1
- +4 DO ONE^SROESTV("VPRY",IEN)
- SET VPRX=$GET(VPRY(IEN))
- if VPRX=""
- QUIT
- +5 SET SURG("id")=IEN
- SET X=$PIECE(VPRX,U,2)
- SET SURG("status")="COMPLETED"
- +6 IF X?1"* Aborted * ".E
- SET X=$EXTRACT(X,13,999)
- SET SURG("status")="ABORTED"
- +7 SET SURG("name")=X
- SET SURG("dateTime")=$PIECE(VPRX,U,3)
- +8 SET X=$PIECE(VPRX,U,4)
- if X
- SET SURG("provider")=$TRANSLATE(X,";","^")_U_$$PROVSPC^VPRD(+X)
- +9 SET X=$$GET1^DIQ(130,IEN_",",50,"I")
- SET SURG("facility")=$$FAC^VPRD(X)
- +10 SET SURG("encounter")=$$GET1^DIQ(130,IEN_",",.015,"I")
- +11 SET X=$$GET1^DIQ(136,IEN_",",.02,"I")
- IF X
- Begin DoDot:1
- +12 SET SURG("type")=$$CPT(X)
- +13 ;CPT modifiers
- DO GETS^DIQ(136,IEN_",","1*","I","VPRMOD")
- +14 SET I=""
- FOR
- SET I=$ORDER(VPRMOD(136.01,I))
- if I=""
- QUIT
- Begin DoDot:2
- +15 SET X=+$GET(VPRMOD(136.01,I,.01,"I"))
- SET Y=$$MOD^ICPTMOD(X,"I")
- +16 SET SURG("modifier",+I)=$PIECE(Y,U,2,3)
- End DoDot:2
- End DoDot:1
- +17 ;other procedures
- DO GETS^DIQ(136,IEN_",","3*","I","VPROTH")
- +18 SET I=""
- FOR
- SET I=$ORDER(VPROTH(136.03,I))
- if I=""
- QUIT
- Begin DoDot:1
- +19 SET X=+$GET(VPROTH(136.03,I,.01,"I"))
- if 'X
- QUIT
- +20 SET SURG("otherProcedure",+I)=$$CPT(X)
- End DoDot:1
- +21 SET I=0
- FOR
- SET I=$ORDER(VPRY(IEN,I))
- if I<1
- QUIT
- SET X=$GET(VPRY(IEN,I))
- IF X
- Begin DoDot:1
- +22 ;draft or retracted
- SET Y=$$INFO^VPRDTIU(+X)
- if Y<1
- QUIT
- +23 SET SURG("document",I)=Y
- +24 if $GET(VPRTEXT)
- SET SURG("document",I,"content")=$$TEXT^VPRDTIU(+X)
- +25 IF Y["OPERATION REPORT"!(Y["PROCEDURE REPORT")
- SET SURG("opReport")=Y
- End DoDot:1
- +26 SET SURG("category")="SR"
- +27 QUIT
- +28 ;
- CPT(IEN) ; -- return code^description for CPT code, or "^" if error
- +1 NEW X0,VPRX,N,I,X,Y
- SET IEN=+$GET(IEN)
- +2 SET X0=$$CPT^ICPTCOD(IEN)
- IF X0<0
- QUIT "^"
- +3 ;CPT Code^Short Name
- SET Y=$PIECE(X0,U,2,3)
- +4 ;CPT Description
- SET N=$$CPTD^ICPTCOD($PIECE(Y,U),"VPRX")
- +5 IF N>0
- IF $LENGTH($GET(VPRX(1)))
- Begin DoDot:1
- +6 SET X=$GET(VPRX(1))
- SET I=1
- +7 FOR
- SET I=$ORDER(VPRX(I))
- if I<1
- QUIT
- if VPRX(I)=" "
- QUIT
- SET X=X_" "_VPRX(I)
- +8 SET $PIECE(Y,U,2)=X
- End DoDot:1
- +9 QUIT Y
- +10 ;
- +11 ; ------------ Return data to middle tier ------------
- +12 ;
- XML(SURG) ; -- Return surgery as XML
- +1 NEW ATT,X,Y,NAMES,I,J
- +2 DO ADD("<surgery>")
- SET VPRTOTL=$GET(VPRTOTL)+1
- +3 SET ATT=""
- FOR
- SET ATT=$ORDER(SURG(ATT))
- if ATT=""
- QUIT
- Begin DoDot:1
- +4 ;multiples
- IF $ORDER(SURG(ATT,0))
- Begin DoDot:2
- +5 DO ADD("<"_ATT_"s>")
- +6 SET I=0
- FOR
- SET I=$ORDER(SURG(ATT,I))
- if I<1
- QUIT
- Begin DoDot:3
- +7 SET X=$GET(SURG(ATT,I))
- SET NAMES=""
- +8 SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^vuid^Z",1:"code^name^Z")
- +9 ;_"/>" D ADD(Y)
- SET Y="<"_ATT_" "_$$LOOP
- +10 SET X=$GET(SURG(ATT,I,"content"))
- IF '$LENGTH(X)
- SET Y=Y_"/>"
- DO ADD(Y)
- QUIT
- +11 SET Y=Y_">"
- DO ADD(Y)
- +12 SET Y="<content xml:space='preserve'>"
- DO ADD(Y)
- +13 SET J=0
- FOR
- SET J=$ORDER(@X@(J))
- if J<1
- QUIT
- SET Y=$$ESC^VPRD(@X@(J))
- DO ADD(Y)
- +14 DO ADD("</content>")
- DO ADD("</"_ATT_">")
- End DoDot:3
- +15 DO ADD("</"_ATT_"s>")
- End DoDot:2
- SET Y=""
- QUIT
- +16 SET X=$GET(SURG(ATT))
- SET Y=""
- if '$LENGTH(X)
- QUIT
- +17 IF X'["^"
- SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
- QUIT
- +18 SET NAMES=$SELECT(ATT="opReport":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,1:"code^name")_"^Z"
- +19 IF $LENGTH(X)>1
- SET Y="<"_ATT_" "_$$LOOP_"/>"
- End DoDot:1
- if $LENGTH(Y)
- DO ADD(Y)
- +20 DO ADD("</surgery>")
- +21 QUIT
- +22 ;
- LOOP() ; -- build sub-items string from NAMES and X
- +1 NEW STR,P,TAG
- SET STR=""
- +2 FOR P=1:1
- SET TAG=$PIECE(NAMES,U,P)
- if TAG="Z"
- QUIT
- IF $LENGTH($PIECE(X,U,P))
- SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
- +3 QUIT STR
- +4 ;
- ADD(X) ; -- Add a line @VPR@(n)=X
- +1 SET VPRI=$GET(VPRI)+1
- +2 SET @VPR@(VPRI)=X
- +3 QUIT