| 1 | PRCHHI9 ;WISC/TGH-IFCAP SEGMENTS DE (CO) ;4/10/92 2:59 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | CO(A2,A3,VAR1,ITEM,NUM) ; Note:
|
|---|
| 5 | ; Comments and Descriptions are at two different levels
|
|---|
| 6 | ;
|
|---|
| 7 | ; A2 = File node level eg A2=2 ! A2=4 ect
|
|---|
| 8 | ; A3 = File node 'type' eg "CO" ! "DE"
|
|---|
| 9 | ; VAR1 = Record Number (Ex. VAR1=99999550)
|
|---|
| 10 | ; ITEM = Item number or "" if doing comments
|
|---|
| 11 | ; LEVEL = Subscript 'level' for storage in 423
|
|---|
| 12 | ;
|
|---|
| 13 | N CNT,CO,COM,DES,DESC,DDIWF,DIWL,DIWR,II,J,N,X,SUB
|
|---|
| 14 | S (CO,DES)=0,II=""
|
|---|
| 15 | S DIWR=60,DIWL=1,DIWF="" K ^UTILITY($J,"W")
|
|---|
| 16 | G:A3'="CO" DISC
|
|---|
| 17 | ;
|
|---|
| 18 | COM ; Comments - '4' in 442
|
|---|
| 19 | S LEVEL=60,SUB="423.21A"
|
|---|
| 20 | S COM=$G(^PRC(442,VAR1,A2,0)) G:COM="" QUIT G:$P(COM,U,4)'>0 QUIT
|
|---|
| 21 | F S CO=$O(^PRC(442,VAR1,A2,CO)) Q:CO'>0 S X=$G(^(CO,0)) D DIWP^PRCUTL($G(DA))
|
|---|
| 22 | G SET
|
|---|
| 23 | DISC ; Item Descriptions - '2' in 442
|
|---|
| 24 | S LEVEL=22,SUB="423.0531A"
|
|---|
| 25 | S DESC=$G(^PRC(442,VAR1,A2,ITEM,1,0)) G:DESC="" QUIT
|
|---|
| 26 | G:$P(DESC,U,4)'>0 QUIT
|
|---|
| 27 | F S DES=$O(^PRC(442,VAR1,A2,ITEM,1,DES)) Q:DES'>0 S X=$G(^(DES,0)) D DIWP^PRCUTL($G(DA))
|
|---|
| 28 | SET S J=$G(^UTILITY($J,"W",1)) G:J'>0 QUIT
|
|---|
| 29 | S CNT=0 ;;$G(^PRCF(423,PRCFA("CSDA"),22,0)),CNT=$P(CNT,U,3)
|
|---|
| 30 | ;
|
|---|
| 31 | ;NOTE -- Need to verify CNT+II level does not already exist!!
|
|---|
| 32 | F II=1:1:J S N=$G(^UTILITY($J,"W",1,II,0)) D
|
|---|
| 33 | .;S ^PRCF(423,PRCFA("CSDA"),LEVEL,(CNT+II),0)=(CNT+II)_"^|"_A3_"^^"_N
|
|---|
| 34 | .;
|
|---|
| 35 | .S NUM=NUM+1,^TMP($J,"STRING",NUM)=A3_"^"_N_"^|"
|
|---|
| 36 | .Q
|
|---|
| 37 | QUIT ;Set 'Top' level
|
|---|
| 38 | ;I $G(J)>0 S ^PRCF(423,PRCFA("CSDA"),LEVEL,0)="^"_SUB_"^"_(CNT+J)_"^"_(CNT+J)
|
|---|
| 39 | Q
|
|---|
