- 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
