- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHHI9 1558 printed Feb 18, 2025@23:34:17 Page 2
- PRCHHI9 ;WISC/TGH-IFCAP SEGMENTS DE (CO) ;4/10/92 2:59 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- CO(A2,A3,VAR1,ITEM,NUM) ; Note:
- +1 ; Comments and Descriptions are at two different levels
- +2 ;
- +3 ; A2 = File node level eg A2=2 ! A2=4 ect
- +4 ; A3 = File node 'type' eg "CO" ! "DE"
- +5 ; VAR1 = Record Number (Ex. VAR1=99999550)
- +6 ; ITEM = Item number or "" if doing comments
- +7 ; LEVEL = Subscript 'level' for storage in 423
- +8 ;
- +9 NEW CNT,CO,COM,DES,DESC,DDIWF,DIWL,DIWR,II,J,N,X,SUB
- +10 SET (CO,DES)=0
- SET II=""
- +11 SET DIWR=60
- SET DIWL=1
- SET DIWF=""
- KILL ^UTILITY($JOB,"W")
- +12 if A3'="CO"
- GOTO DISC
- +13 ;
- COM ; Comments - '4' in 442
- +1 SET LEVEL=60
- SET SUB="423.21A"
- +2 SET COM=$GET(^PRC(442,VAR1,A2,0))
- if COM=""
- GOTO QUIT
- if $PIECE(COM,U,4)'>0
- GOTO QUIT
- +3 FOR
- SET CO=$ORDER(^PRC(442,VAR1,A2,CO))
- if CO'>0
- QUIT
- SET X=$GET(^(CO,0))
- DO DIWP^PRCUTL($GET(DA))
- +4 GOTO SET
- DISC ; Item Descriptions - '2' in 442
- +1 SET LEVEL=22
- SET SUB="423.0531A"
- +2 SET DESC=$GET(^PRC(442,VAR1,A2,ITEM,1,0))
- if DESC=""
- GOTO QUIT
- +3 if $PIECE(DESC,U,4)'>0
- GOTO QUIT
- +4 FOR
- SET DES=$ORDER(^PRC(442,VAR1,A2,ITEM,1,DES))
- if DES'>0
- QUIT
- SET X=$GET(^(DES,0))
- DO DIWP^PRCUTL($GET(DA))
- SET SET J=$GET(^UTILITY($JOB,"W",1))
- if J'>0
- GOTO QUIT
- +1 ;;$G(^PRCF(423,PRCFA("CSDA"),22,0)),CNT=$P(CNT,U,3)
- SET CNT=0
- +2 ;
- +3 ;NOTE -- Need to verify CNT+II level does not already exist!!
- +4 FOR II=1:1:J
- SET N=$GET(^UTILITY($JOB,"W",1,II,0))
- Begin DoDot:1
- +5 ;S ^PRCF(423,PRCFA("CSDA"),LEVEL,(CNT+II),0)=(CNT+II)_"^|"_A3_"^^"_N
- +6 ;
- +7 SET NUM=NUM+1
- SET ^TMP($JOB,"STRING",NUM)=A3_"^"_N_"^|"
- +8 QUIT
- End DoDot:1
- QUIT ;Set 'Top' level
- +1 ;I $G(J)>0 S ^PRCF(423,PRCFA("CSDA"),LEVEL,0)="^"_SUB_"^"_(CNT+J)_"^"_(CNT+J)
- +2 QUIT