OOPSGUI3 ;WIOFO/LLH-UTILITY BROKER CALLS ;10/03/01
;;2.0;ASISTS;**8,7**;Jun 03, 2002
;
SETLCK(RESULTS,IEN) ; Set Lock on Claim being edited
; Input: IEN - ASISTS Internal record number to be locked
; Output: RESULTS - Status message, if record not locked
;
I '$G(IEN) S RESULTS="Need Record Number to proceed" Q
L +^OOPS(2260,IEN):2
E S RESULTS="Another User Editing Record, Try Again Later." Q
S RESULTS="RECORD LOCKED"
Q
CLRLCK(RESULTS,IEN) ; Clears Lock on Claim being edited
; Input: IEN - ASISTS Internal record number to be cleared
; Output: RESULTS - Status message, if appropriate
;
I '$G(IEN) S RESULTS="Need Record Number to proceed" Q
L -^OOPS(2260,IEN)
S RESULTS="RECORD UNLOCKED"
Q
GETLIST(RESULTS,FLD) ; RPC Call - Get Pointed to List
; Input: FLD - will be the file and field # in FILE,FIELD format.
; if there is a 3 piece of FLD, it will contain the
; piece number of an extra data element to be
; returned. The format is FILE^FIELD^PIECE#
; Output: RESULTS - return array
;
N FILE,FIELD,TYPE
S FILE=$P($G(FLD),U),FIELD=$P($G(FLD),U,2)
S TYPE=$$GET1^DID(FILE,FIELD,"","TYPE")
I TYPE="SET" D SET1 Q
I TYPE="POINTER" D SET3 Q
Q
SET1 ;-- extract a set of codes --
EN2 N LIST,MUTL,X
S LIST=$$GET1^DID(2260,FIELD,"","POINTER")
I $E(LIST,1,3)="OOPS" G SET3
S MULT=$$GET1^DID(2260,FIELD,"","SPECIFIER")
I MULT["A" D
. S LIST=$$GET1^DID(+MULT,.01,"","POINTER")
F X=1:1 Q:$P($G(LIST),";",X)']"" S RESULTS(X)=$P($G(LIST),";",X)
Q
SET3 ;-- extract items from pointed-to file --
N ADDED,ITEM,MULT,ROOT,X,XREF,SFLD,VAL,PTR,PCE,VALID
S XREF="B",X=0
S ROOT="^"_$$GET1^DID(FILE,FIELD,"","POINTER")
S MULT=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
I MULT["A" D
. S ROOT="^"_$$GET1^DID(+MULT,.01,"","POINTER")
S ITEM="" F S ITEM=$O(@(ROOT_"XREF,ITEM)")) Q:$G(ITEM)']"" D
.S PTR=0 F S PTR=$O(@(ROOT_"XREF,ITEM,PTR)")) Q:PTR="" D
..I PTR'?1N.N Q
..S VAL=$P(@(ROOT_PTR_",0)"),U)
..;Need to get Station Number with Name to uniquely identify for user
..I FIELD=13 D I '$G(VALID) Q
...S VALID=1,SFLD=ROOT_PTR_",99)"
...I $P($G(@SFLD),U,4)=1 S VALID=0
...I $P($G(@SFLD),U)'="" S VAL=VAL_" = "_$P($G(@SFLD),U)
...I $P(VAL," = ")="" S VALID=0
..I (FILE=2260)&(FIELD=30!(FIELD=62)!(FIELD=70)!(FIELD=123)!(FIELD=124)!(FIELD=126)) D
... S SFLD=ROOT_PTR_",0)"
... I $P($G(@SFLD),U,2)'="" S VAL=VAL_" - "_$P($G(@SFLD),U,2)
..S X=X+1,RESULTS(X)=PTR_":"_VAL
..I $P($G(FLD),U,3)]"" D
...S PCE=$P($G(FLD),U,3)
...S RESULTS(X)=RESULTS(X)_":"_$P(@(ROOT_"PTR,0)"),U,PCE)
Q
;
GETSCHED(RESULTS,INPUT) ;
; Input: INPUT - Is the file, field #, and IEN in
; FILE^FIELD^IEN fmt
; Output: RESULTS - return array (Integers indicating schedule)
;
S RESULTS(1)="*"
N CODE,LAST,DATA,DAY,Y,X,FIELD,FILE,IEN,ROOT,XREF,NODE,PIECE
S FILE=$P($G(INPUT),U),FIELD=$P($G(INPUT),U,2)
S IEN=$P($G(INPUT),U,3),ROOT=$$GET1^DID(FILE,"","","GLOBAL NAME")
I '$G(IEN) Q
S XREF=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
S NODE=$P($G(XREF),";"),PIECE=$P($G(XREF),";",2)
S CODE=$P($G(@(ROOT_"IEN,NODE)")),U,PIECE) Q:$G(CODE)']""
S LAST=$L(CODE,",")
F X=1:1:LAST D
.S DATA=$P($G(CODE),",",X) Q:$G(DATA)']"" D
.I $G(DATA)'["-" S DAY(DATA)=$G(DATA) Q
.F Y=$P(DATA,"-",1):1:$P(DATA,"-",2) S DAY(Y)=Y
S X=0
F D Q:+X'>0
.S X=$O(DAY(X)) Q:+X'>0 S RESULTS(1)=RESULTS(1)_","_X
Q
;
REPLMULT(RESULTS,INPUT,DATA) ;
; Input: INPUT - contains the FILE, FIELD, and IEN of the record
; to have the data filed into.
; DATA - contains the replacement data (internal code/ptr)
; Output: RESULTS - results array to be sent back to client
;
D REPLIN,REPLDEL,REPLADD
K DA,DIK,FILE,FIELD,NODE,ROOT,SAVEDIK,SUB
Q
REPLIN ;
S FILE=$P($G(INPUT),U),FIELD=$P($G(INPUT),U,2),DA(1)=$P($G(INPUT),U,3)
S ROOT=$$ROOT^DILFD(FILE,0,"GL")
S SUB=$$GET1^DID(2260,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
S NODE=$P($G(SUB),";"),PCE=$P($G(SUB),";",2)
S SAVEDIK=ROOT_DA(1)_","_$C(34)_NODE_$C(34)_","
Q
REPLDEL ;
S DA=0,DIK=SAVEDIK
F S DA=$O(@(ROOT_"DA(1),NODE,DA)")) Q:(+DA'>0) D ^DIK
Q
REPLADD ;
N CNT,DIC,DLAYGO,X
S DLAYGO=DA(1),DIC=SAVEDIK,DIC(0)="LNX"
S CNT=0
F D Q:+CNT'>0
. S CNT=$O(DATA(CNT)) Q:+CNT'>0
. S X=DATA(CNT)
. K DD,DO D FILE^DICN
Q
;
BODY(RESULTS) ; get valid Body Parts from file 2261.1
; Input: - none
; Output: RESULTS - an array containing the body parts
;
N PP,COUNT,DATA,BPIEN,BPGRP,BODY
S (PP,COUNT)=0
F S PP=$O(^OOPS(2261.1,PP)) Q:+PP'>0 D
. Q:$P(^OOPS(2261.1,PP,0),U,2)=0
. Q:+$P(^OOPS(2261.1,PP,0),U,2)>0
. S DATA=^OOPS(2261.1,PP,0)
. ; patch 5 llh - get Body Part Group IEN and Name and send back
. S BPIEN=$P($G(DATA),U,3),BPGRP=""
. I $G(BPIEN) S BPGRP=$P($G(^OOPS(2263.8,BPIEN,0)),U) D
.. S BODY(BPGRP)=BPIEN
. S RESULTS(COUNT)=$P(DATA,U)_" - "_$P(DATA,U,2)_U_BPGRP
. S COUNT=COUNT+1
S BPGRP=""
F S BPGRP=$O(BODY(BPGRP)) Q:BPGRP="" D
. S RESULTS(COUNT)=U_BPGRP_U_BODY(BPGRP),COUNT=COUNT+1
QUIT
GETDATA(RESULTS,INPUT) ; Retrieves Set of Code, WP, and Multiple valued fields
; for any file and field passed in the INPUT parameter
; Input - INPUT contains the File & Field # of the file to retrieve the
; data from and the File IEN. The format is FILE^FIELD^IEN
; Output - RESULTS, the array containing the data being returned
;
N IEN,FILE,FIELD,NODE,PCE,ROOT,TYP,SUB
S FILE=$P($G(INPUT),U),FIELD=$P($G(INPUT),U,2),IEN=$P($G(INPUT),U,3)
I $G(IEN)=""!($G(FILE)="")!($G(FIELD)="") Q
S ROOT=$$ROOT^DILFD(FILE,0,"GL")
S TYP=$$GET1^DID(FILE,FIELD,"","TYPE")
S SUB=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
S NODE=$P($G(SUB),";"),PCE=$P($G(SUB),";",2)
I TYP="POINTER",PCE>0 D PTR Q
I TYP="POINTER",PCE=0 D PTRMULT Q
I TYP="SET",PCE>0 D SET Q
I TYP="SET",PCE=0 D SETMULT Q
I TYP="WORD-PROCESSING" D WPFLD Q
Q
SET ;
N CODE,LIST,X
S CODE=$P(@(ROOT_"IEN,NODE)"),U,PCE)
EN1 S LIST=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
I +LIST S FILE=+LIST,FIELD=.01 G EN1
S LIST=$$GET1^DID(FILE,FIELD,"","POINTER")
I $G(LIST)="" Q
F X=1:1 Q:$P(LIST,";",X)']"" I $P($P(LIST,";",X),":")=CODE S RESULTS(1)=$P(LIST,";",X)
Q
;
SETMULT ;
N A,LIST,REC,DATA,X
ENM S LIST=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
I +LIST S FILE=+LIST,FIELD=.01 G ENM
S LIST=$$GET1^DID(FILE,FIELD,"","POINTER")
I $G(LIST)="" Q
S (REC,X)=0 F D Q:+REC'>0
.S REC=$O(@(ROOT_"IEN,NODE,REC)")) Q:+REC'>0
.S DATA=@(ROOT_"IEN,NODE,REC,0)")
.S A=$P($G(LIST),DATA_":",2)
.S X=X+1
.S RESULTS(X)=$G(DATA)_":"_$P($G(A),";")
Q
PTR ; Pointer fields
N PTR,PROOT
S PTR=$P(@(ROOT_"IEN,NODE)"),U,PIECE)
S PROOT="^"_$$GET1^DID(FILE,FIELD,"","POINTER")
S RESULTS(1)=PTR_":"_$P(@(PROOT_"PTR,0)"),U,1)
Q
PTRMULT ; Multiple pointer value fields
N DATA,XROOT,PROOT,REC,RECORD,X
S XROOT=+$$GET1^DID(FILE,FIELD,"","SPECIFIER")
S PROOT="^"_$$GET1^DID(XROOT,.01,"","POINTER")
S (REC,X)=0 F D Q:+REC'>0
.S REC=$O(@(ROOT_"IEN,NODE,REC)")) Q:+REC'>0
.S RECORD=@(ROOT_"IEN,NODE,REC,0)")
.S DATA=$P($G(RECORD),U,1)
.S X=X+1,RESULTS(X)=$G(DATA)_":"_$P(@(PROOT_"DATA,0)"),U,1)
Q
WPFLD ; Word processing fields
N DA
S DA=0 F D Q:+DA'>0
.S DA=$O(@(ROOT_"IEN,NODE,DA)")) Q:+DA'>0
.S RESULTS(DA)=@(ROOT_"IEN,NODE,DA,0)")
Q
;
STATINFO(RESULTS,STATIEN) ;Get Station Info from DIC(4
; Input STATIEN - Required valid IEN for a station in DIC 4.
; Output RESULTS - Station Address info stored in this format
; STREET^CITY^STATE^ZIP or if not a valid IEN
; "INVALID STATION"
N STATE,CITY,ADDR,ZIP
I $$GET1^DIQ(4,STATIEN,.01)="" S RESULTS(0)="INVALID STATION" Q
S STATE=$$GET1^DIQ(4,STATIEN,.02)
S CITY=$$GET1^DIQ(4,STATIEN,1.03)
S ADDR=$$GET1^DIQ(4,STATIEN,1.01)
S ZIP=$$GET1^DIQ(4,STATIEN,1.04)
S RESULTS(0)=ADDR_U_CITY_U_STATE_U_ZIP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HOOPSGUI3 8013 printed Dec 13, 2024@01:39:01 Page 2
OOPSGUI3 ;WIOFO/LLH-UTILITY BROKER CALLS ;10/03/01
+1 ;;2.0;ASISTS;**8,7**;Jun 03, 2002
+2 ;
SETLCK(RESULTS,IEN) ; Set Lock on Claim being edited
+1 ; Input: IEN - ASISTS Internal record number to be locked
+2 ; Output: RESULTS - Status message, if record not locked
+3 ;
+4 IF '$GET(IEN)
SET RESULTS="Need Record Number to proceed"
QUIT
+5 LOCK +^OOPS(2260,IEN):2
+6 IF '$TEST
SET RESULTS="Another User Editing Record, Try Again Later."
QUIT
+7 SET RESULTS="RECORD LOCKED"
+8 QUIT
CLRLCK(RESULTS,IEN) ; Clears Lock on Claim being edited
+1 ; Input: IEN - ASISTS Internal record number to be cleared
+2 ; Output: RESULTS - Status message, if appropriate
+3 ;
+4 IF '$GET(IEN)
SET RESULTS="Need Record Number to proceed"
QUIT
+5 LOCK -^OOPS(2260,IEN)
+6 SET RESULTS="RECORD UNLOCKED"
+7 QUIT
GETLIST(RESULTS,FLD) ; RPC Call - Get Pointed to List
+1 ; Input: FLD - will be the file and field # in FILE,FIELD format.
+2 ; if there is a 3 piece of FLD, it will contain the
+3 ; piece number of an extra data element to be
+4 ; returned. The format is FILE^FIELD^PIECE#
+5 ; Output: RESULTS - return array
+6 ;
+7 NEW FILE,FIELD,TYPE
+8 SET FILE=$PIECE($GET(FLD),U)
SET FIELD=$PIECE($GET(FLD),U,2)
+9 SET TYPE=$$GET1^DID(FILE,FIELD,"","TYPE")
+10 IF TYPE="SET"
DO SET1
QUIT
+11 IF TYPE="POINTER"
DO SET3
QUIT
+12 QUIT
SET1 ;-- extract a set of codes --
EN2 NEW LIST,MUTL,X
+1 SET LIST=$$GET1^DID(2260,FIELD,"","POINTER")
+2 IF $EXTRACT(LIST,1,3)="OOPS"
GOTO SET3
+3 SET MULT=$$GET1^DID(2260,FIELD,"","SPECIFIER")
+4 IF MULT["A"
Begin DoDot:1
+5 SET LIST=$$GET1^DID(+MULT,.01,"","POINTER")
End DoDot:1
+6 FOR X=1:1
if $PIECE($GET(LIST),";",X)']""
QUIT
SET RESULTS(X)=$PIECE($GET(LIST),";",X)
+7 QUIT
SET3 ;-- extract items from pointed-to file --
+1 NEW ADDED,ITEM,MULT,ROOT,X,XREF,SFLD,VAL,PTR,PCE,VALID
+2 SET XREF="B"
SET X=0
+3 SET ROOT="^"_$$GET1^DID(FILE,FIELD,"","POINTER")
+4 SET MULT=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
+5 IF MULT["A"
Begin DoDot:1
+6 SET ROOT="^"_$$GET1^DID(+MULT,.01,"","POINTER")
End DoDot:1
+7 SET ITEM=""
FOR
SET ITEM=$ORDER(@(ROOT_"XREF,ITEM)"))
if $GET(ITEM)']""
QUIT
Begin DoDot:1
+8 SET PTR=0
FOR
SET PTR=$ORDER(@(ROOT_"XREF,ITEM,PTR)"))
if PTR=""
QUIT
Begin DoDot:2
+9 IF PTR'?1N.N
QUIT
+10 SET VAL=$PIECE(@(ROOT_PTR_",0)"),U)
+11 ;Need to get Station Number with Name to uniquely identify for user
+12 IF FIELD=13
Begin DoDot:3
+13 SET VALID=1
SET SFLD=ROOT_PTR_",99)"
+14 IF $PIECE($GET(@SFLD),U,4)=1
SET VALID=0
+15 IF $PIECE($GET(@SFLD),U)'=""
SET VAL=VAL_" = "_$PIECE($GET(@SFLD),U)
+16 IF $PIECE(VAL," = ")=""
SET VALID=0
End DoDot:3
IF '$GET(VALID)
QUIT
+17 IF (FILE=2260)&(FIELD=30!(FIELD=62)!(FIELD=70)!(FIELD=123)!(FIELD=124)!(FIELD=126))
Begin DoDot:3
+18 SET SFLD=ROOT_PTR_",0)"
+19 IF $PIECE($GET(@SFLD),U,2)'=""
SET VAL=VAL_" - "_$PIECE($GET(@SFLD),U,2)
End DoDot:3
+20 SET X=X+1
SET RESULTS(X)=PTR_":"_VAL
+21 IF $PIECE($GET(FLD),U,3)]""
Begin DoDot:3
+22 SET PCE=$PIECE($GET(FLD),U,3)
+23 SET RESULTS(X)=RESULTS(X)_":"_$PIECE(@(ROOT_"PTR,0)"),U,PCE)
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
GETSCHED(RESULTS,INPUT) ;
+1 ; Input: INPUT - Is the file, field #, and IEN in
+2 ; FILE^FIELD^IEN fmt
+3 ; Output: RESULTS - return array (Integers indicating schedule)
+4 ;
+5 SET RESULTS(1)="*"
+6 NEW CODE,LAST,DATA,DAY,Y,X,FIELD,FILE,IEN,ROOT,XREF,NODE,PIECE
+7 SET FILE=$PIECE($GET(INPUT),U)
SET FIELD=$PIECE($GET(INPUT),U,2)
+8 SET IEN=$PIECE($GET(INPUT),U,3)
SET ROOT=$$GET1^DID(FILE,"","","GLOBAL NAME")
+9 IF '$GET(IEN)
QUIT
+10 SET XREF=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+11 SET NODE=$PIECE($GET(XREF),";")
SET PIECE=$PIECE($GET(XREF),";",2)
+12 SET CODE=$PIECE($GET(@(ROOT_"IEN,NODE)")),U,PIECE)
if $GET(CODE)']""
QUIT
+13 SET LAST=$LENGTH(CODE,",")
+14 FOR X=1:1:LAST
Begin DoDot:1
+15 SET DATA=$PIECE($GET(CODE),",",X)
if $GET(DATA)']""
QUIT
Begin DoDot:2
End DoDot:2
+16 IF $GET(DATA)'["-"
SET DAY(DATA)=$GET(DATA)
QUIT
+17 FOR Y=$PIECE(DATA,"-",1):1:$PIECE(DATA,"-",2)
SET DAY(Y)=Y
End DoDot:1
+18 SET X=0
+19 FOR
Begin DoDot:1
+20 SET X=$ORDER(DAY(X))
if +X'>0
QUIT
SET RESULTS(1)=RESULTS(1)_","_X
End DoDot:1
if +X'>0
QUIT
+21 QUIT
+22 ;
REPLMULT(RESULTS,INPUT,DATA) ;
+1 ; Input: INPUT - contains the FILE, FIELD, and IEN of the record
+2 ; to have the data filed into.
+3 ; DATA - contains the replacement data (internal code/ptr)
+4 ; Output: RESULTS - results array to be sent back to client
+5 ;
+6 DO REPLIN
DO REPLDEL
DO REPLADD
+7 KILL DA,DIK,FILE,FIELD,NODE,ROOT,SAVEDIK,SUB
+8 QUIT
REPLIN ;
+1 SET FILE=$PIECE($GET(INPUT),U)
SET FIELD=$PIECE($GET(INPUT),U,2)
SET DA(1)=$PIECE($GET(INPUT),U,3)
+2 SET ROOT=$$ROOT^DILFD(FILE,0,"GL")
+3 SET SUB=$$GET1^DID(2260,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+4 SET NODE=$PIECE($GET(SUB),";")
SET PCE=$PIECE($GET(SUB),";",2)
+5 SET SAVEDIK=ROOT_DA(1)_","_$CHAR(34)_NODE_$CHAR(34)_","
+6 QUIT
REPLDEL ;
+1 SET DA=0
SET DIK=SAVEDIK
+2 FOR
SET DA=$ORDER(@(ROOT_"DA(1),NODE,DA)"))
if (+DA'>0)
QUIT
DO ^DIK
+3 QUIT
REPLADD ;
+1 NEW CNT,DIC,DLAYGO,X
+2 SET DLAYGO=DA(1)
SET DIC=SAVEDIK
SET DIC(0)="LNX"
+3 SET CNT=0
+4 FOR
Begin DoDot:1
+5 SET CNT=$ORDER(DATA(CNT))
if +CNT'>0
QUIT
+6 SET X=DATA(CNT)
+7 KILL DD,DO
DO FILE^DICN
End DoDot:1
if +CNT'>0
QUIT
+8 QUIT
+9 ;
BODY(RESULTS) ; get valid Body Parts from file 2261.1
+1 ; Input: - none
+2 ; Output: RESULTS - an array containing the body parts
+3 ;
+4 NEW PP,COUNT,DATA,BPIEN,BPGRP,BODY
+5 SET (PP,COUNT)=0
+6 FOR
SET PP=$ORDER(^OOPS(2261.1,PP))
if +PP'>0
QUIT
Begin DoDot:1
+7 if $PIECE(^OOPS(2261.1,PP,0),U,2)=0
QUIT
+8 if +$PIECE(^OOPS(2261.1,PP,0),U,2)>0
QUIT
+9 SET DATA=^OOPS(2261.1,PP,0)
+10 ; patch 5 llh - get Body Part Group IEN and Name and send back
+11 SET BPIEN=$PIECE($GET(DATA),U,3)
SET BPGRP=""
+12 IF $GET(BPIEN)
SET BPGRP=$PIECE($GET(^OOPS(2263.8,BPIEN,0)),U)
Begin DoDot:2
+13 SET BODY(BPGRP)=BPIEN
End DoDot:2
+14 SET RESULTS(COUNT)=$PIECE(DATA,U)_" - "_$PIECE(DATA,U,2)_U_BPGRP
+15 SET COUNT=COUNT+1
End DoDot:1
+16 SET BPGRP=""
+17 FOR
SET BPGRP=$ORDER(BODY(BPGRP))
if BPGRP=""
QUIT
Begin DoDot:1
+18 SET RESULTS(COUNT)=U_BPGRP_U_BODY(BPGRP)
SET COUNT=COUNT+1
End DoDot:1
+19 QUIT
GETDATA(RESULTS,INPUT) ; Retrieves Set of Code, WP, and Multiple valued fields
+1 ; for any file and field passed in the INPUT parameter
+2 ; Input - INPUT contains the File & Field # of the file to retrieve the
+3 ; data from and the File IEN. The format is FILE^FIELD^IEN
+4 ; Output - RESULTS, the array containing the data being returned
+5 ;
+6 NEW IEN,FILE,FIELD,NODE,PCE,ROOT,TYP,SUB
+7 SET FILE=$PIECE($GET(INPUT),U)
SET FIELD=$PIECE($GET(INPUT),U,2)
SET IEN=$PIECE($GET(INPUT),U,3)
+8 IF $GET(IEN)=""!($GET(FILE)="")!($GET(FIELD)="")
QUIT
+9 SET ROOT=$$ROOT^DILFD(FILE,0,"GL")
+10 SET TYP=$$GET1^DID(FILE,FIELD,"","TYPE")
+11 SET SUB=$$GET1^DID(FILE,FIELD,"","GLOBAL SUBSCRIPT LOCATION")
+12 SET NODE=$PIECE($GET(SUB),";")
SET PCE=$PIECE($GET(SUB),";",2)
+13 IF TYP="POINTER"
IF PCE>0
DO PTR
QUIT
+14 IF TYP="POINTER"
IF PCE=0
DO PTRMULT
QUIT
+15 IF TYP="SET"
IF PCE>0
DO SET
QUIT
+16 IF TYP="SET"
IF PCE=0
DO SETMULT
QUIT
+17 IF TYP="WORD-PROCESSING"
DO WPFLD
QUIT
+18 QUIT
SET ;
+1 NEW CODE,LIST,X
+2 SET CODE=$PIECE(@(ROOT_"IEN,NODE)"),U,PCE)
EN1 SET LIST=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
+1 IF +LIST
SET FILE=+LIST
SET FIELD=.01
GOTO EN1
+2 SET LIST=$$GET1^DID(FILE,FIELD,"","POINTER")
+3 IF $GET(LIST)=""
QUIT
+4 FOR X=1:1
if $PIECE(LIST,";",X)']""
QUIT
IF $PIECE($PIECE(LIST,";",X),":")=CODE
SET RESULTS(1)=$PIECE(LIST,";",X)
+5 QUIT
+6 ;
SETMULT ;
+1 NEW A,LIST,REC,DATA,X
ENM SET LIST=$$GET1^DID(FILE,FIELD,"","SPECIFIER")
+1 IF +LIST
SET FILE=+LIST
SET FIELD=.01
GOTO ENM
+2 SET LIST=$$GET1^DID(FILE,FIELD,"","POINTER")
+3 IF $GET(LIST)=""
QUIT
+4 SET (REC,X)=0
FOR
Begin DoDot:1
+5 SET REC=$ORDER(@(ROOT_"IEN,NODE,REC)"))
if +REC'>0
QUIT
+6 SET DATA=@(ROOT_"IEN,NODE,REC,0)")
+7 SET A=$PIECE($GET(LIST),DATA_":",2)
+8 SET X=X+1
+9 SET RESULTS(X)=$GET(DATA)_":"_$PIECE($GET(A),";")
End DoDot:1
if +REC'>0
QUIT
+10 QUIT
PTR ; Pointer fields
+1 NEW PTR,PROOT
+2 SET PTR=$PIECE(@(ROOT_"IEN,NODE)"),U,PIECE)
+3 SET PROOT="^"_$$GET1^DID(FILE,FIELD,"","POINTER")
+4 SET RESULTS(1)=PTR_":"_$PIECE(@(PROOT_"PTR,0)"),U,1)
+5 QUIT
PTRMULT ; Multiple pointer value fields
+1 NEW DATA,XROOT,PROOT,REC,RECORD,X
+2 SET XROOT=+$$GET1^DID(FILE,FIELD,"","SPECIFIER")
+3 SET PROOT="^"_$$GET1^DID(XROOT,.01,"","POINTER")
+4 SET (REC,X)=0
FOR
Begin DoDot:1
+5 SET REC=$ORDER(@(ROOT_"IEN,NODE,REC)"))
if +REC'>0
QUIT
+6 SET RECORD=@(ROOT_"IEN,NODE,REC,0)")
+7 SET DATA=$PIECE($GET(RECORD),U,1)
+8 SET X=X+1
SET RESULTS(X)=$GET(DATA)_":"_$PIECE(@(PROOT_"DATA,0)"),U,1)
End DoDot:1
if +REC'>0
QUIT
+9 QUIT
WPFLD ; Word processing fields
+1 NEW DA
+2 SET DA=0
FOR
Begin DoDot:1
+3 SET DA=$ORDER(@(ROOT_"IEN,NODE,DA)"))
if +DA'>0
QUIT
+4 SET RESULTS(DA)=@(ROOT_"IEN,NODE,DA,0)")
End DoDot:1
if +DA'>0
QUIT
+5 QUIT
+6 ;
STATINFO(RESULTS,STATIEN) ;Get Station Info from DIC(4
+1 ; Input STATIEN - Required valid IEN for a station in DIC 4.
+2 ; Output RESULTS - Station Address info stored in this format
+3 ; STREET^CITY^STATE^ZIP or if not a valid IEN
+4 ; "INVALID STATION"
+5 NEW STATE,CITY,ADDR,ZIP
+6 IF $$GET1^DIQ(4,STATIEN,.01)=""
SET RESULTS(0)="INVALID STATION"
QUIT
+7 SET STATE=$$GET1^DIQ(4,STATIEN,.02)
+8 SET CITY=$$GET1^DIQ(4,STATIEN,1.03)
+9 SET ADDR=$$GET1^DIQ(4,STATIEN,1.01)
+10 SET ZIP=$$GET1^DIQ(4,STATIEN,1.04)
+11 SET RESULTS(0)=ADDR_U_CITY_U_STATE_U_ZIP
+12 QUIT
