APCLV08 ; IHS/CMI/LAB - procedure functions ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in E,C,P
;
PROC ;EP
I 'V Q -1
I '$D(^AUPNVSIT(V)) Q -1
I '$G(N) Q -1
NEW %,Y,P,C,Z
S (Z,P)="",(Y,C)=0
S Y=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y S C=C+1 I C=N S P=$P(^AUPNVPRC(Y,0),U),Z=Y
I 'P Q P
I '$D(^ICD0(P)) Q -1
I $G(F)="" S F="C"
S %="" D @F
Q %
;
PRC ;EP
NEW Z,C,%,S
S (C,Y)=0 F S Y=$O(^AUPNVPRC("AD",V,Y)) Q:Y'=+Y S C=C+1 S APCLV(C)="",P=$P(^AUPNVPRC(Y,0),U),Z=Y D
.I F=99 D Q
..F I=1:1 S S=$T(@I) Q:S="" S %="" D @I S $P(APCLV(C),U,I)=%
.I F[";" D Q
..F J=1:1 S I=$P(F,";",J) Q:I="" I I'=99 S %="" D @I S $P(APCLV(C),U,J)=%
.S %="",I=F D @I S $P(APCLV(C),U)=%
.Q
Q
I ;
S %=P Q
E ;
;S %=$P(^ICD0(P,0),U,4) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P($$ICDOP^ICDEX(P,,,"I"),U,5) Q ;cmi/anch/maw 9/12/2007 csv
C ;
;S %=$P(^ICD0(P,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P($$ICDOP^ICDEX(P,,,"I"),U,2) Q ;cmi/anch/maw 9/12/2007 csv
D ;
S %=$P(^AUPNVPRC(Z,0),U,6) Q
G ;
D D I %]"" S %=$$FMTE^XLFDT(%) Q
P ;
;S %=$P(^AUPNVPRC(Z,0),U,16) I % S %=$P(^ICPT(%,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
S %=$P(^AUPNVPRC(Z,0),U,16) I % S %=$P($$CPT^ICPTCOD(%),U,2) Q ;cmi/anch/maw 9/12/2007 csv
Q
T ;
S %=$P(^AUPNVPRC(Z,0),U,16) Q
N ;
S %=$P(^AUPNVPRC(Z,0),U,4) I % S %=$P(^AUTNPOV(%,0),U)
Q
F ;
S %=$P(^AUPNVPRC(Z,0),U,8) Q
R ;
S P=$P(^AUPNVPRC(Z,0),U,11) I P D O^APCLV06
Q
X ;diagnosis done for
NEW M S M=$P(^AUPNVPRC(Z,0),U,5)
S I=$$PRIMPOV^APCLV(V,"I") I M=I S %=1 Q
F I=1:1:15 S J=$$SECPOV^APCLV(V,"I",I) I J]"",J=M S %=I+1 Q
Q
APCLV08 ; IHS/CMI/LAB - procedure functions ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in E,C,P
+4 ;
PROC ;EP
+1 IF 'V
QUIT -1
+2 IF '$DATA(^AUPNVSIT(V))
QUIT -1
+3 IF '$GET(N)
QUIT -1
+4 NEW %,Y,P,C,Z
+5 SET (Z,P)=""
SET (Y,C)=0
+6 SET Y=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
IF C=N
SET P=$PIECE(^AUPNVPRC(Y,0),U)
SET Z=Y
+7 IF 'P
QUIT P
+8 IF '$DATA(^ICD0(P))
QUIT -1
+9 IF $GET(F)=""
SET F="C"
+10 SET %=""
DO @F
+11 QUIT %
+12 ;
PRC ;EP
+1 NEW Z,C,%,S
+2 SET (C,Y)=0
FOR
SET Y=$ORDER(^AUPNVPRC("AD",V,Y))
IF Y'=+Y
QUIT
SET C=C+1
SET APCLV(C)=""
SET P=$PIECE(^AUPNVPRC(Y,0),U)
SET Z=Y
Begin DoDot:1
+3 IF F=99
Begin DoDot:2
+4 FOR I=1:1
SET S=$TEXT(@I)
IF S=""
QUIT
SET %=""
DO @I
SET $PIECE(APCLV(C),U,I)=%
End DoDot:2
QUIT
+5 IF F[";"
Begin DoDot:2
+6 FOR J=1:1
SET I=$PIECE(F,";",J)
IF I=""
QUIT
IF I'=99
SET %=""
DO @I
SET $PIECE(APCLV(C),U,J)=%
End DoDot:2
QUIT
+7 SET %=""
SET I=F
DO @I
SET $PIECE(APCLV(C),U)=%
+8 QUIT
End DoDot:1
+9 QUIT
I ;
+1 SET %=P
QUIT
E ;
+1 ;S %=$P(^ICD0(P,0),U,4) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET %=$PIECE($$ICDOP^ICDEX(P,,,"I"),U,5)
QUIT
C ;
+1 ;S %=$P(^ICD0(P,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET %=$PIECE($$ICDOP^ICDEX(P,,,"I"),U,2)
QUIT
D ;
+1 SET %=$PIECE(^AUPNVPRC(Z,0),U,6)
QUIT
G ;
+1 DO D
IF %]""
SET %=$$FMTE^XLFDT(%)
QUIT
P ;
+1 ;S %=$P(^AUPNVPRC(Z,0),U,16) I % S %=$P(^ICPT(%,0),U) Q ;cmi/anch/maw 9/12/2007 orig line
+2 ;cmi/anch/maw 9/12/2007 csv
SET %=$PIECE(^AUPNVPRC(Z,0),U,16)
IF %
SET %=$PIECE($$CPT^ICPTCOD(%),U,2)
QUIT
+3 QUIT
T ;
+1 SET %=$PIECE(^AUPNVPRC(Z,0),U,16)
QUIT
N ;
+1 SET %=$PIECE(^AUPNVPRC(Z,0),U,4)
IF %
SET %=$PIECE(^AUTNPOV(%,0),U)
+2 QUIT
F ;
+1 SET %=$PIECE(^AUPNVPRC(Z,0),U,8)
QUIT
R ;
+1 SET P=$PIECE(^AUPNVPRC(Z,0),U,11)
IF P
DO O^APCLV06
+2 QUIT
X ;diagnosis done for
+1 NEW M
SET M=$PIECE(^AUPNVPRC(Z,0),U,5)
+2 SET I=$$PRIMPOV^APCLV(V,"I")
IF M=I
SET %=1
QUIT
+3 FOR I=1:1:15
SET J=$$SECPOV^APCLV(V,"I",I)
IF J]""
IF J=M
SET %=I+1
QUIT
+4 QUIT
