VENPCC1F ; IHS/OIT/GIS - SURGICAL, PERSONAL FAMILY HISTORY ;
;;2.6;PCC+;;NOV 12, 2007
;
; ALSO CONTAINS CODE FOR PODIATRY
;
HX(DFN,DEFEF) ; EP - GET HX INFO FOR THIS PATIENT
I $D(^DPT(+$G(DFN),0)),$D(^VEN(7.41,+$G(DEFEF),0))
E Q
X "I $P($G(^VEN(7.41,DEFEF,5)),U,18),$L($T(SURG^VENPCC1K)) D SURG^VENPCC1K(DFN,DEFEF)" ; SURG HX
N CNT,PIEN,VPIEN,IDT,FMDT,HDT,PRVIEN,DX,DXIEN,PROC,PRV,STG,X,Y,%,PN,PNIEN,FIEN,ICD,HIEN,FMODT,ODT,MAX,T,TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
HOS I '$P($G(^VEN(7.41,DEFEF,5)),U,4) G FH ; HX OF SURGERY
S CNT=0,IDT=0,MAX=5
I $P($G(^VEN(7.41,DEFEF,5)),U,11) S MAX=1 ; LIMIT MAX NO TO 1 - LAST ONE ONLY
F S IDT=$O(^AUPNVPRC("AA",DFN,IDT)) Q:'IDT S VPIEN=999999999 F S VPIEN=$O(^AUPNVPRC("AA",DFN,IDT,VPIEN),-1) Q:'VPIEN D I CNT=MAX G H1
. S X=$G(^AUPNVPRC(VPIEN,0)) I '$L(X) Q
. S PIEN=+X I 'PIEN Q
. S ICD=+$P($G(^ICD0(PIEN,0)),U) I 'ICD Q ; ICD CODE
. I $P($G(^VEN(7.41,DEFEF,5)),U,7) K T D I $G(T) Q ; EXCLUDE MINOR PROCEDURES
.. I ICD>85 S T=1 Q
.. I ICD=69.7 S T=1 Q
.. I ICD\1=24 S T=1 Q
.. I ICD=38.99 S T=1 Q
.. I ICD\1=23 S T=1
.. Q
. S PROC=$P($G(^ICD0(PIEN,1)),U) I '$L(PROC) Q ; PROCEDURE NAME
. S FMDT=$P(X,U,6) I 'FMDT Q
. S HDT=$$FMTE^XLFDT(FMDT,"2D") ; PROCEDURE DATE IN M/D/Y FORMAT
. I $P($G(^VEN(7.41,DEFEF,5)),U,5) D ; DIAGNOSIS
.. K DX
.. S DXIEN=$P(X,U,5) I 'DXIEN Q
.. S DX=$P($G(^ICD9(DXIEN,0)),U,3)
.. Q
. I $P($G(^VEN(7.41,DEFEF,5)),U,6) D ; PROVIDER NAME
.. K PRV
.. S PRVIEN=$P(X,U,11) I 'PRVIEN Q
.. S %=U_"DIC("_16_")",PRV=$E($S($P($G(^AUTTSITE(1,0)),U,22):$P($G(^VA(200,PRVIEN,0)),U),1:$P($G(@%@(PRVIEN,0)),U)),1,15) ; PATCHED BY GIS 3/17/04
.. Q
. S Y=PROC_" ("_ICD_") "_HDT
. I $L($G(PRV)) S Y=Y_" By: "_PRV
. I $L($G(DX)) S Y=Y_" Dx: "_DX
. I $L(Y) S CNT=CNT+1,STG(CNT)=Y
. Q
H1 ; OUTPUT HX SURG
F CNT=1:1:MAX S X=$G(STG(CNT)) I $L(X) S @TMP@("v"_CNT)=X
;
FH I '$P($G(^VEN(7.41,DEFEF,5)),U,8) G PH ; FAMILY HISTORY
S CNT=0
S FIEN=999999999 F S FIEN=$O(^AUPNFH("AC",DFN,FIEN),-1) Q:'FIEN D I CNT=5 G PH
. S X=$G(^AUPNFH(FIEN,0)) I '$L(X) Q
. S DXIEN=+X I 'DXIEN Q
. S ICD=$P($G(^ICD9(DXIEN,0)),U) I '$L(ICD) Q
. S FMDT=$P(X,U,3) I 'FMDT Q
. S HDT=$$FMTE^XLFDT(FMDT,"2D")
. S PNIEN=$P(X,U,4) I 'PNIEN Q
. S PN=$P($G(^AUTNPOV(PNIEN,0)),U) I '$L(PN) Q
. S CNT=CNT+1,@TMP@("v"_(5+CNT))=PN_" ("_ICD_") "_HDT
. Q
Q
;
PH I '$P($G(^VEN(7.41,DEFEF,5)),U,9) G PODHX ; EP-PERSONAL HISTORY
N TMP
S TMP=$NA(^TMP("VEN PRNT",$J,1))
S CNT=0
S HIEN=999999999 F S HIEN=$O(^AUPNPH("AC",DFN,HIEN),-1) Q:'HIEN D I CNT=5 G PODHX ; PATCHED BY GIS 3/19/04
. S X=$G(^AUPNPH(HIEN,0)) I '$L(X) Q
. S DXIEN=+X I 'DXIEN Q
. S ICD=$P($G(^ICD9(DXIEN,0)),U) I '$L(ICD) Q
. S FMDT=$P(X,U,3) I 'FMDT Q
. S HDT=$$FMTE^XLFDT(FMDT,"2D")
. S PNIEN=$P(X,U,4) I 'PNIEN Q
. S PN=$P($G(^AUTNPOV(PNIEN,0)),U) I '$L(PN) Q
. S CNT=CNT+1,Y=PN_" ("_ICD_") "_HDT
. I '$P($G(^VEN(7.41,DEFEF,5)),U,10) S FMODT=$P(X,U,5) I FMODT S ODT=$$FMTE^XLFDT(FMODT,"2D") I $L(ODT) S Y=Y_" Onset: "_ODT
. S @TMP@("v"_(10+CNT))=Y
. Q
Q
;
PODHX I '$P($G(^VEN(7.41,DEFEF,5)),U,16) Q ; EP-PODIATRY HISTORY
I '$L($T(^APCHSPOD)) Q ; PODIATRY HS MUST EXIST OR NOT AN OFFICIAL INSTALL
N TMP,LN,LS,CNT,X,Y,Z,%,STG,VSTG,TXT,T,NSTG
N CODE,RES,LG,GIEN,GSTG,SIDE,ASTG,AIEN,INC,SSTG,SN
S TMP="^TMP(""VEN PRNT"","_$J_",1)",T="~"
S STG=$G(^AUPNPOD(+$G(DFN),0)) I '$L(STG) Q
VASC S Y=$P(STG,U,2) I Y D
. X ^DD("DD") S @TMP@("c50")=Y ; c50 DATE LAST VASC EXAM
. S VSTG=$G(^AUPNPOD(DFN,1))
. S Y=$P(VSTG,U,1),Z=$P(VSTG,U,2)
. I Y D ; GET PULSE INFO
.. X ^DD("DD") S @TMP@("c51")=Y ; c51 DATE LAST PULSE CHECK
.. S %=$P(Z,T,1) I $L(%) S @TMP@("c52")=%
.. S %=$P(Z,T,2) I $L(%) S @TMP@("c53")=%
.. S %=$P(Z,T,3) I $L(%) S @TMP@("c54")=%
.. S %=$P(Z,T,4) I $L(%) S @TMP@("c55")=%
.. Q
. S Y=$P(VSTG,U,3),Z=$P(VSTG,U,4)
. I Y D ; GET DOPPLER INFO
.. X ^DD("DD") S @TMP@("c56")=Y ; c56 DATE LAST DOPPLER EXAM
.. S %=$P(Z,T,1) I $L(%) S @TMP@("c57")=%
.. S %=$P(Z,T,2) I $L(%) S @TMP@("c58")=%
.. S %=$P(Z,T,3) I $L(%) S @TMP@("c59")=%
.. S %=$P(Z,T,4) I $L(%) S @TMP@("c60")=%
.. S %=$P(Z,T,5) I $L(%) S @TMP@("c48")=%
.. S %=$P(Z,T,6) I $L(%) S @TMP@("c49")=%
.. Q
. S Y=$P(VSTG,U,5),Z=$P(VSTG,U,6)
. I Y D ; GET OSCILLOMETRY INFO
.. X ^DD("DD") S @TMP@("c61")=Y ; c61 DATE LAST OSCILLOMETRY EXAM
.. S %=$P(Z,T,1) I $L(%) S @TMP@("c62")=%
.. S %=$P(Z,T,2) I $L(%) S @TMP@("c63")=%
.. S %=$P(Z,T,3) I $L(%) S @TMP@("c64")=%
.. S %=$P(Z,T,4) I $L(%) S @TMP@("c65")=%
.. S TXT=$P(Z,T,5) I $L(TXT) D
... S %=$P(Z,T,6) I $L(%) S @TMP@("c66")=(TXT_"="_%)
... S %=$P(Z,T,7) I $L(%) S @TMP@("c67")=(TXT_"="_%)
... Q
.. Q
. Q
NEURO S Y=$P(STG,U,3) I Y D ; EP-NEURO EXAM
. X ^DD("DD") S LN=Y
. S NSTG=$G(^AUPNPOD(DFN,2))
. S RES=$P(NSTG,U,1) I RES D
.. I RES=1 S @TMP@("c40")="X"
.. I RES=2 S @TMP@("c41")="X"
.. I RES=3 S @TMP@("c42")="X"
. S @TMP@("c68")=LN ; c68 LAST NEURO EXAM
. S @TMP@("c47")=$P(NSTG,U,2)
. Q
GRAFT I $D(^AUPNPOD(DFN,3)) D ; EP-GRAFTS
. S GIEN=999999
. F CNT=69:1:72 S GIEN=$O(^AUPNPOD(DFN,3,GIEN),-1) Q:'GIEN D
.. S GSTG=$G(^AUPNPOD(DFN,3,GIEN,0)) I '$L(GSTG) Q
.. S Y=+GSTG I 'Y Q
.. X ^DD("DD") S LG=Y
.. S LG=LG_" "_$P(GSTG,U,2)
.. S @TMP@("c"_CNT)=LG ; c69-c72 GRAFTS
.. Q
. Q
AMP I $D(^AUPNPOD(DFN,4)) D ; EP-AMPUTATIONS
. S AIEN=0
. F S AIEN=$O(^AUPNPOD(DFN,4,AIEN)) Q:'AIEN D
.. S ASTG=$G(^AUPNPOD(DFN,4,AIEN,0)) I '$L(ASTG) Q
.. S TYPE=+ASTG,SIDE=$P(ASTG,U,2),TXT=$P(ASTG,U,3)
.. I 'TYPE Q
.. I SIDE="" Q
.. I TXT="" Q
.. S INC=(SIDE="R")
.. S CNT=(TYPE*2)+INC+71
.. S @TMP@("c"_CNT)=TXT ; c73-c98 AMPUTATIONS
.. Q
. Q
SHOE S Y=$P(STG,U,4) I Y D ; EP-SHOE FITTING
. X ^DD("DD") S SN=Y
. S SSTG=$G(^AUPNPOD(DFN,5))
. S RES=$P(SSTG,U,1) I RES D
.. I RES=1 S @TMP@("c43")="X"
.. I RES=2 S @TMP@("c44")="X"
.. I RES=3 S @TMP@("c45")="X"
.. I RES=4 S @TMP@("c46")=$P(SSTG,U,2),@TMP@("c99")="X"
.. Q
. S @TMP@("c100")=SN ; c100 LAST SHOE FITTING
. Q
Q
;
VENPCC1F ; IHS/OIT/GIS - SURGICAL, PERSONAL FAMILY HISTORY ;
+1 ;;2.6;PCC+;;NOV 12, 2007
+2 ;
+3 ; ALSO CONTAINS CODE FOR PODIATRY
+4 ;
HX(DFN,DEFEF) ; EP - GET HX INFO FOR THIS PATIENT
+1 IF $DATA(^DPT(+$GET(DFN),0))
IF $DATA(^VEN(7.41,+$GET(DEFEF),0))
+2 IF '$TEST
QUIT
+3 ; SURG HX
XECUTE "I $P($G(^VEN(7.41,DEFEF,5)),U,18),$L($T(SURG^VENPCC1K)) D SURG^VENPCC1K(DFN,DEFEF)"
+4 NEW CNT,PIEN,VPIEN,IDT,FMDT,HDT,PRVIEN,DX,DXIEN,PROC,PRV,STG,X,Y,%,PN,PNIEN,FIEN,ICD,HIEN,FMODT,ODT,MAX,T,TMP
+5 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
HOS ; HX OF SURGERY
IF '$PIECE($GET(^VEN(7.41,DEFEF,5)),U,4)
GOTO FH
+1 SET CNT=0
SET IDT=0
SET MAX=5
+2 ; LIMIT MAX NO TO 1 - LAST ONE ONLY
IF $PIECE($GET(^VEN(7.41,DEFEF,5)),U,11)
SET MAX=1
+3 FOR
SET IDT=$ORDER(^AUPNVPRC("AA",DFN,IDT))
IF 'IDT
QUIT
SET VPIEN=999999999
FOR
SET VPIEN=$ORDER(^AUPNVPRC("AA",DFN,IDT,VPIEN),-1)
IF 'VPIEN
QUIT
Begin DoDot:1
+4 SET X=$GET(^AUPNVPRC(VPIEN,0))
IF '$LENGTH(X)
QUIT
+5 SET PIEN=+X
IF 'PIEN
QUIT
+6 ; ICD CODE
SET ICD=+$PIECE($GET(^ICD0(PIEN,0)),U)
IF 'ICD
QUIT
+7 ; EXCLUDE MINOR PROCEDURES
IF $PIECE($GET(^VEN(7.41,DEFEF,5)),U,7)
KILL T
Begin DoDot:2
+8 IF ICD>85
SET T=1
QUIT
+9 IF ICD=69.7
SET T=1
QUIT
+10 IF ICD\1=24
SET T=1
QUIT
+11 IF ICD=38.99
SET T=1
QUIT
+12 IF ICD\1=23
SET T=1
+13 QUIT
End DoDot:2
IF $GET(T)
QUIT
+14 ; PROCEDURE NAME
SET PROC=$PIECE($GET(^ICD0(PIEN,1)),U)
IF '$LENGTH(PROC)
QUIT
+15 SET FMDT=$PIECE(X,U,6)
IF 'FMDT
QUIT
+16 ; PROCEDURE DATE IN M/D/Y FORMAT
SET HDT=$$FMTE^XLFDT(FMDT,"2D")
+17 ; DIAGNOSIS
IF $PIECE($GET(^VEN(7.41,DEFEF,5)),U,5)
Begin DoDot:2
+18 KILL DX
+19 SET DXIEN=$PIECE(X,U,5)
IF 'DXIEN
QUIT
+20 SET DX=$PIECE($GET(^ICD9(DXIEN,0)),U,3)
+21 QUIT
End DoDot:2
+22 ; PROVIDER NAME
IF $PIECE($GET(^VEN(7.41,DEFEF,5)),U,6)
Begin DoDot:2
+23 KILL PRV
+24 SET PRVIEN=$PIECE(X,U,11)
IF 'PRVIEN
QUIT
+25 ; PATCHED BY GIS 3/17/04
SET %=U_"DIC("_16_")"
SET PRV=$EXTRACT($SELECT($PIECE($GET(^AUTTSITE(1,0)),U,22):$PIECE($GET(^VA(200,PRVIEN,0)),U),1:$PIECE($GET(@%@(PRVIEN,0)),U)),1,15)
+26 QUIT
End DoDot:2
+27 SET Y=PROC_" ("_ICD_") "_HDT
+28 IF $LENGTH($GET(PRV))
SET Y=Y_" By: "_PRV
+29 IF $LENGTH($GET(DX))
SET Y=Y_" Dx: "_DX
+30 IF $LENGTH(Y)
SET CNT=CNT+1
SET STG(CNT)=Y
+31 QUIT
End DoDot:1
IF CNT=MAX
GOTO H1
H1 ; OUTPUT HX SURG
+1 FOR CNT=1:1:MAX
SET X=$GET(STG(CNT))
IF $LENGTH(X)
SET @TMP@("v"_CNT)=X
+2 ;
FH ; FAMILY HISTORY
IF '$PIECE($GET(^VEN(7.41,DEFEF,5)),U,8)
GOTO PH
+1 SET CNT=0
+2 SET FIEN=999999999
FOR
SET FIEN=$ORDER(^AUPNFH("AC",DFN,FIEN),-1)
IF 'FIEN
QUIT
Begin DoDot:1
+3 SET X=$GET(^AUPNFH(FIEN,0))
IF '$LENGTH(X)
QUIT
+4 SET DXIEN=+X
IF 'DXIEN
QUIT
+5 SET ICD=$PIECE($GET(^ICD9(DXIEN,0)),U)
IF '$LENGTH(ICD)
QUIT
+6 SET FMDT=$PIECE(X,U,3)
IF 'FMDT
QUIT
+7 SET HDT=$$FMTE^XLFDT(FMDT,"2D")
+8 SET PNIEN=$PIECE(X,U,4)
IF 'PNIEN
QUIT
+9 SET PN=$PIECE($GET(^AUTNPOV(PNIEN,0)),U)
IF '$LENGTH(PN)
QUIT
+10 SET CNT=CNT+1
SET @TMP@("v"_(5+CNT))=PN_" ("_ICD_") "_HDT
+11 QUIT
End DoDot:1
IF CNT=5
GOTO PH
+12 QUIT
+13 ;
PH ; EP-PERSONAL HISTORY
IF '$PIECE($GET(^VEN(7.41,DEFEF,5)),U,9)
GOTO PODHX
+1 NEW TMP
+2 SET TMP=$NAME(^TMP("VEN PRNT",$JOB,1))
+3 SET CNT=0
+4 ; PATCHED BY GIS 3/19/04
SET HIEN=999999999
FOR
SET HIEN=$ORDER(^AUPNPH("AC",DFN,HIEN),-1)
IF 'HIEN
QUIT
Begin DoDot:1
+5 SET X=$GET(^AUPNPH(HIEN,0))
IF '$LENGTH(X)
QUIT
+6 SET DXIEN=+X
IF 'DXIEN
QUIT
+7 SET ICD=$PIECE($GET(^ICD9(DXIEN,0)),U)
IF '$LENGTH(ICD)
QUIT
+8 SET FMDT=$PIECE(X,U,3)
IF 'FMDT
QUIT
+9 SET HDT=$$FMTE^XLFDT(FMDT,"2D")
+10 SET PNIEN=$PIECE(X,U,4)
IF 'PNIEN
QUIT
+11 SET PN=$PIECE($GET(^AUTNPOV(PNIEN,0)),U)
IF '$LENGTH(PN)
QUIT
+12 SET CNT=CNT+1
SET Y=PN_" ("_ICD_") "_HDT
+13 IF '$PIECE($GET(^VEN(7.41,DEFEF,5)),U,10)
SET FMODT=$PIECE(X,U,5)
IF FMODT
SET ODT=$$FMTE^XLFDT(FMODT,"2D")
IF $LENGTH(ODT)
SET Y=Y_" Onset: "_ODT
+14 SET @TMP@("v"_(10+CNT))=Y
+15 QUIT
End DoDot:1
IF CNT=5
GOTO PODHX
+16 QUIT
+17 ;
PODHX ; EP-PODIATRY HISTORY
IF '$PIECE($GET(^VEN(7.41,DEFEF,5)),U,16)
QUIT
+1 ; PODIATRY HS MUST EXIST OR NOT AN OFFICIAL INSTALL
IF '$LENGTH($TEXT(^APCHSPOD))
QUIT
+2 NEW TMP,LN,LS,CNT,X,Y,Z,%,STG,VSTG,TXT,T,NSTG
+3 NEW CODE,RES,LG,GIEN,GSTG,SIDE,ASTG,AIEN,INC,SSTG,SN
+4 SET TMP="^TMP(""VEN PRNT"","_$JOB_",1)"
SET T="~"
+5 SET STG=$GET(^AUPNPOD(+$GET(DFN),0))
IF '$LENGTH(STG)
QUIT
VASC SET Y=$PIECE(STG,U,2)
IF Y
Begin DoDot:1
+1 ; c50 DATE LAST VASC EXAM
XECUTE ^DD("DD")
SET @TMP@("c50")=Y
+2 SET VSTG=$GET(^AUPNPOD(DFN,1))
+3 SET Y=$PIECE(VSTG,U,1)
SET Z=$PIECE(VSTG,U,2)
+4 ; GET PULSE INFO
IF Y
Begin DoDot:2
+5 ; c51 DATE LAST PULSE CHECK
XECUTE ^DD("DD")
SET @TMP@("c51")=Y
+6 SET %=$PIECE(Z,T,1)
IF $LENGTH(%)
SET @TMP@("c52")=%
+7 SET %=$PIECE(Z,T,2)
IF $LENGTH(%)
SET @TMP@("c53")=%
+8 SET %=$PIECE(Z,T,3)
IF $LENGTH(%)
SET @TMP@("c54")=%
+9 SET %=$PIECE(Z,T,4)
IF $LENGTH(%)
SET @TMP@("c55")=%
+10 QUIT
End DoDot:2
+11 SET Y=$PIECE(VSTG,U,3)
SET Z=$PIECE(VSTG,U,4)
+12 ; GET DOPPLER INFO
IF Y
Begin DoDot:2
+13 ; c56 DATE LAST DOPPLER EXAM
XECUTE ^DD("DD")
SET @TMP@("c56")=Y
+14 SET %=$PIECE(Z,T,1)
IF $LENGTH(%)
SET @TMP@("c57")=%
+15 SET %=$PIECE(Z,T,2)
IF $LENGTH(%)
SET @TMP@("c58")=%
+16 SET %=$PIECE(Z,T,3)
IF $LENGTH(%)
SET @TMP@("c59")=%
+17 SET %=$PIECE(Z,T,4)
IF $LENGTH(%)
SET @TMP@("c60")=%
+18 SET %=$PIECE(Z,T,5)
IF $LENGTH(%)
SET @TMP@("c48")=%
+19 SET %=$PIECE(Z,T,6)
IF $LENGTH(%)
SET @TMP@("c49")=%
+20 QUIT
End DoDot:2
+21 SET Y=$PIECE(VSTG,U,5)
SET Z=$PIECE(VSTG,U,6)
+22 ; GET OSCILLOMETRY INFO
IF Y
Begin DoDot:2
+23 ; c61 DATE LAST OSCILLOMETRY EXAM
XECUTE ^DD("DD")
SET @TMP@("c61")=Y
+24 SET %=$PIECE(Z,T,1)
IF $LENGTH(%)
SET @TMP@("c62")=%
+25 SET %=$PIECE(Z,T,2)
IF $LENGTH(%)
SET @TMP@("c63")=%
+26 SET %=$PIECE(Z,T,3)
IF $LENGTH(%)
SET @TMP@("c64")=%
+27 SET %=$PIECE(Z,T,4)
IF $LENGTH(%)
SET @TMP@("c65")=%
+28 SET TXT=$PIECE(Z,T,5)
IF $LENGTH(TXT)
Begin DoDot:3
+29 SET %=$PIECE(Z,T,6)
IF $LENGTH(%)
SET @TMP@("c66")=(TXT_"="_%)
+30 SET %=$PIECE(Z,T,7)
IF $LENGTH(%)
SET @TMP@("c67")=(TXT_"="_%)
+31 QUIT
End DoDot:3
+32 QUIT
End DoDot:2
+33 QUIT
End DoDot:1
NEURO ; EP-NEURO EXAM
SET Y=$PIECE(STG,U,3)
IF Y
Begin DoDot:1
+1 XECUTE ^DD("DD")
SET LN=Y
+2 SET NSTG=$GET(^AUPNPOD(DFN,2))
+3 SET RES=$PIECE(NSTG,U,1)
IF RES
Begin DoDot:2
+4 IF RES=1
SET @TMP@("c40")="X"
+5 IF RES=2
SET @TMP@("c41")="X"
+6 IF RES=3
SET @TMP@("c42")="X"
End DoDot:2
+7 ; c68 LAST NEURO EXAM
SET @TMP@("c68")=LN
+8 SET @TMP@("c47")=$PIECE(NSTG,U,2)
+9 QUIT
End DoDot:1
GRAFT ; EP-GRAFTS
IF $DATA(^AUPNPOD(DFN,3))
Begin DoDot:1
+1 SET GIEN=999999
+2 FOR CNT=69:1:72
SET GIEN=$ORDER(^AUPNPOD(DFN,3,GIEN),-1)
IF 'GIEN
QUIT
Begin DoDot:2
+3 SET GSTG=$GET(^AUPNPOD(DFN,3,GIEN,0))
IF '$LENGTH(GSTG)
QUIT
+4 SET Y=+GSTG
IF 'Y
QUIT
+5 XECUTE ^DD("DD")
SET LG=Y
+6 SET LG=LG_" "_$PIECE(GSTG,U,2)
+7 ; c69-c72 GRAFTS
SET @TMP@("c"_CNT)=LG
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
AMP ; EP-AMPUTATIONS
IF $DATA(^AUPNPOD(DFN,4))
Begin DoDot:1
+1 SET AIEN=0
+2 FOR
SET AIEN=$ORDER(^AUPNPOD(DFN,4,AIEN))
IF 'AIEN
QUIT
Begin DoDot:2
+3 SET ASTG=$GET(^AUPNPOD(DFN,4,AIEN,0))
IF '$LENGTH(ASTG)
QUIT
+4 SET TYPE=+ASTG
SET SIDE=$PIECE(ASTG,U,2)
SET TXT=$PIECE(ASTG,U,3)
+5 IF 'TYPE
QUIT
+6 IF SIDE=""
QUIT
+7 IF TXT=""
QUIT
+8 SET INC=(SIDE="R")
+9 SET CNT=(TYPE*2)+INC+71
+10 ; c73-c98 AMPUTATIONS
SET @TMP@("c"_CNT)=TXT
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
SHOE ; EP-SHOE FITTING
SET Y=$PIECE(STG,U,4)
IF Y
Begin DoDot:1
+1 XECUTE ^DD("DD")
SET SN=Y
+2 SET SSTG=$GET(^AUPNPOD(DFN,5))
+3 SET RES=$PIECE(SSTG,U,1)
IF RES
Begin DoDot:2
+4 IF RES=1
SET @TMP@("c43")="X"
+5 IF RES=2
SET @TMP@("c44")="X"
+6 IF RES=3
SET @TMP@("c45")="X"
+7 IF RES=4
SET @TMP@("c46")=$PIECE(SSTG,U,2)
SET @TMP@("c99")="X"
+8 QUIT
End DoDot:2
+9 ; c100 LAST SHOE FITTING
SET @TMP@("c100")=SN
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
