40 lines
1.5 KiB
Mathematica
40 lines
1.5 KiB
Mathematica
PRCHHI9 ;WISC/TGH-IFCAP SEGMENTS DE (CO) ;4/10/92 2:59 PM
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
CO(A2,A3,VAR1,ITEM,NUM) ; Note:
|
|
; Comments and Descriptions are at two different levels
|
|
;
|
|
; A2 = File node level eg A2=2 ! A2=4 ect
|
|
; A3 = File node 'type' eg "CO" ! "DE"
|
|
; VAR1 = Record Number (Ex. VAR1=99999550)
|
|
; ITEM = Item number or "" if doing comments
|
|
; LEVEL = Subscript 'level' for storage in 423
|
|
;
|
|
N CNT,CO,COM,DES,DESC,DDIWF,DIWL,DIWR,II,J,N,X,SUB
|
|
S (CO,DES)=0,II=""
|
|
S DIWR=60,DIWL=1,DIWF="" K ^UTILITY($J,"W")
|
|
G:A3'="CO" DISC
|
|
;
|
|
COM ; Comments - '4' in 442
|
|
S LEVEL=60,SUB="423.21A"
|
|
S COM=$G(^PRC(442,VAR1,A2,0)) G:COM="" QUIT G:$P(COM,U,4)'>0 QUIT
|
|
F S CO=$O(^PRC(442,VAR1,A2,CO)) Q:CO'>0 S X=$G(^(CO,0)) D DIWP^PRCUTL($G(DA))
|
|
G SET
|
|
DISC ; Item Descriptions - '2' in 442
|
|
S LEVEL=22,SUB="423.0531A"
|
|
S DESC=$G(^PRC(442,VAR1,A2,ITEM,1,0)) G:DESC="" QUIT
|
|
G:$P(DESC,U,4)'>0 QUIT
|
|
F S DES=$O(^PRC(442,VAR1,A2,ITEM,1,DES)) Q:DES'>0 S X=$G(^(DES,0)) D DIWP^PRCUTL($G(DA))
|
|
SET S J=$G(^UTILITY($J,"W",1)) G:J'>0 QUIT
|
|
S CNT=0 ;;$G(^PRCF(423,PRCFA("CSDA"),22,0)),CNT=$P(CNT,U,3)
|
|
;
|
|
;NOTE -- Need to verify CNT+II level does not already exist!!
|
|
F II=1:1:J S N=$G(^UTILITY($J,"W",1,II,0)) D
|
|
.;S ^PRCF(423,PRCFA("CSDA"),LEVEL,(CNT+II),0)=(CNT+II)_"^|"_A3_"^^"_N
|
|
.;
|
|
.S NUM=NUM+1,^TMP($J,"STRING",NUM)=A3_"^"_N_"^|"
|
|
.Q
|
|
QUIT ;Set 'Top' level
|
|
;I $G(J)>0 S ^PRCF(423,PRCFA("CSDA"),LEVEL,0)="^"_SUB_"^"_(CNT+J)_"^"_(CNT+J)
|
|
Q
|