Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHHI9

PRCHHI9.m

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