- IS00031B ;Compiled from script 'Generated: HL IHS DW1ALPMR A08-O' on MAY 21, 2015
- ;Part 3
- ;Copyright 2015 SAIC
- EN S @INV@("ZPL7")=X K DXS,D0
- ;SET ZPL8 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB8
- S D0=INDA S X=$G(INA("BDW1ZPB8",INI(1)))
- S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- S @INV@("ZPL8")=X K DXS,D0
- ;SET ZPL9 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB9
- S D0=INDA S X=$G(INA("BDW1ZPB9",INI(1)))
- S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- S @INV@("ZPL9")=X K DXS,D0
- ;SET ZPL10 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB10
- S D0=INDA S X=$G(INA("BDW1ZPB10",INI(1)))
- S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- S @INV@("ZPL10")=X K DXS,D0
- ;SET ZPL11 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB11
- S D0=INDA S X=$G(INA("BDW1ZPB11",INI(1)))
- S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- S @INV@("ZPL11")=X K DXS,D0
- D:'INVS MC^INHS
- K LINE S LINE="",CP=0 S L1="ZPL" S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,1,L1,.CP) S L1=$G(@INV@("ZPL1")) S:$TR(L1,$G(SUBDELIM))="" L1=""
- D SETPIECE^INHU(.LINE,DELIM,2,L1,.CP) S L1=$G(@INV@("ZPL2")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,3,L1,.CP) S L1=$G(@INV@("ZPL3"))
- S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,4,L1,.CP) S L1=$G(@INV@("ZPL4")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- S L1=$G(@INV@("ZPL5")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,6,L1,.CP) S L1=$G(@INV@("ZPL6")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,7,L1,.CP)
- S L1=$G(@INV@("ZPL7")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,8,L1,.CP) S L1=$G(@INV@("ZPL8")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,9,L1,.CP)
- S L1=$G(@INV@("ZPL9")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,10,L1,.CP) S L1=$G(@INV@("ZPL10")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,11,L1,.CP)
- S L1=$G(@INV@("ZPL11")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,12,L1,.CP)
- S LCT=LCT+1,^UTILITY("INH",$J,LCT)=LINE I $D(LINE)>9 M ^UTILITY("INH",$J,LCT)=LINE
- Q
- A1 S INDA=INDA0 K INDA0
- SET INSETID=0
- S INDA0=INDA,INI(1)=0 F S INI(1)=$O(INDA("ZRF",INI(1))) Q:'INI(1) S INDA=$S(INDA("ZRF",INI(1)):INDA("ZRF",INI(1)),1:INI(1)) D
- .;SET ZRF1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF1
- .S D0=INDA S X=$G(INA("BDW1ZRF1",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF1")=X K DXS,D0
- .;SET ZRF2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF2
- .S D0=INDA S X=$G(INA("BDW1ZRF2",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF2")=X K DXS,D0
- .;SET ZRF3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF3
- .S D0=INDA S X=$G(INA("BDW1ZRF3",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF3")=X K DXS,D0
- .;SET ZRF4 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF4
- .S D0=INDA S X=$G(INA("BDW1ZRF4",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF4")=X K DXS,D0
- .;SET ZRF5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF5
- .S D0=INDA S X=$G(INA("BDW1ZRF5",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF5")=X K DXS,D0
- .;SET ZRF6 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF6
- .S D0=INDA S X=$G(INA("BDW1ZRF6",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF6")=X K DXS,D0
- .;SET ZRF7 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF7
- .S D0=INDA S X=$G(INA("BDW1ZRF7",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZRF7")=X K DXS,D0
- .D:'INVS MC^INHS
- .K LINE S LINE="",CP=0 S L1="ZRF" S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,1,L1,.CP) S L1=$G(@INV@("ZRF1")) S:$TR(L1,$G(SUBDELIM))="" L1=""
- .D SETPIECE^INHU(.LINE,DELIM,2,L1,.CP) S L1=$G(@INV@("ZRF2")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,3,L1,.CP) S L1=$G(@INV@("ZRF3"))
- .S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,4,L1,.CP) S L1=$G(@INV@("ZRF4")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- .S L1=$G(@INV@("ZRF5")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,6,L1,.CP) S L1=$G(@INV@("ZRF6")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,7,L1,.CP)
- .S L1=$G(@INV@("ZRF7")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,8,L1,.CP)
- .S LCT=LCT+1,^UTILITY("INH",$J,LCT)=LINE I $D(LINE)>9 M ^UTILITY("INH",$J,LCT)=LINE
- .Q
- S INDA=INDA0 K INDA0
- SET INSETID=0
- S INDA0=INDA,INI(1)=0 F S INI(1)=$O(INDA("ZMC",INI(1))) Q:'INI(1) S INDA=$S(INDA("ZMC",INI(1)):INDA("ZMC",INI(1)),1:INI(1)) D
- .;SET ZMC1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC1
- .S D0=INDA S X=$G(INA("BDW1ZMC1",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZMC1")=X K DXS,D0
- .;SET ZMC2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC2
- .S D0=INDA S X=$G(INA("BDW1ZMC2",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZMC2")=X K DXS,D0
- .;SET ZMC3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC3
- .S D0=INDA S X=$G(INA("BDW1ZMC3",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZMC3")=X K DXS,D0
- .;SET ZMC4 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC4
- .S D0=INDA S X=$G(INA("BDW1ZMC4",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZMC4")=X K DXS,D0
- .;SET ZMC5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC5
- .S D0=INDA S X=$G(INA("BDW1ZMC5",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("ZMC5")=X K DXS,D0
- .D:'INVS MC^INHS
- .K LINE S LINE="",CP=0 S L1="ZMC" S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,1,L1,.CP) S L1=$G(@INV@("ZMC1")) S:$TR(L1,$G(SUBDELIM))="" L1=""
- .D SETPIECE^INHU(.LINE,DELIM,2,L1,.CP) S L1=$G(@INV@("ZMC2")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,3,L1,.CP) S L1=$G(@INV@("ZMC3"))
- .S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,4,L1,.CP) S L1=$G(@INV@("ZMC4")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- .S L1=$G(@INV@("ZMC5")) S:$TR(L1,$G(SUBDELIM))="" L1="" D SETPIECE^INHU(.LINE,DELIM,6,L1,.CP)
- .S LCT=LCT+1,^UTILITY("INH",$J,LCT)=LINE I $D(LINE)>9 M ^UTILITY("INH",$J,LCT)=LINE
- .Q
- S INDA=INDA0 K INDA0
- SET INSETID=0
- S INDA0=INDA,INI(1)=0 F S INI(1)=$O(INDA("WHP",INI(1))) Q:'INI(1) S INDA=$S(INDA("WHP",INI(1)):INDA("WHP",INI(1)),1:INI(1)) D
- .;SET OBX1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH1
- .S D0=INDA S X=$G(INA("BDW1WH1",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("OBX1")=X K DXS,D0
- .;SET OBX2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH2
- .S D0=INDA S X=$G(INA("BDW1WH2",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("OBX2")=X K DXS,D0
- .;SET OBX3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH3
- .S D0=INDA S X=$G(INA("BDW1WH3",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("OBX3")=X K DXS,D0
- .;SET OBX4 = ""
- .S D0=INDA S X=""
- .S @INV@("OBX4")=X K DXS,D0
- .;SET OBX5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH5
- .S D0=INDA S X=$G(INA("BDW1WH5",INI(1)))
- .S X1="^INTHL7FT(1,3)" X:$L($G(@X1)) $G(@X1) S X=$E(X,1,999)
- .S @INV@("OBX5")=X K DXS,D0
- .;SET OBX6 = ""
- .S D0=INDA S X=""
- .S @INV@("OBX6")=X K DXS,D0
- .;SET OBX7 = ""
- .S D0=INDA S X=""
- .S @INV@("OBX7")=X K DXS,D0
- .;SET OBX8 = ""
- .S D0=INDA S X=""
- 9 .D EN^IS00031C
- G D1^IS00031C
- IS00031B ;Compiled from script 'Generated: HL IHS DW1ALPMR A08-O' on MAY 21, 2015
- +1 ;Part 3
- +2 ;Copyright 2015 SAIC
- EN SET @INV@("ZPL7")=X
- KILL DXS,D0
- +1 ;SET ZPL8 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB8
- +2 SET D0=INDA
- SET X=$GET(INA("BDW1ZPB8",INI(1)))
- +3 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +4 SET @INV@("ZPL8")=X
- KILL DXS,D0
- +5 ;SET ZPL9 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB9
- +6 SET D0=INDA
- SET X=$GET(INA("BDW1ZPB9",INI(1)))
- +7 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +8 SET @INV@("ZPL9")=X
- KILL DXS,D0
- +9 ;SET ZPL10 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB10
- +10 SET D0=INDA
- SET X=$GET(INA("BDW1ZPB10",INI(1)))
- +11 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +12 SET @INV@("ZPL10")=X
- KILL DXS,D0
- +13 ;SET ZPL11 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZPB11
- +14 SET D0=INDA
- SET X=$GET(INA("BDW1ZPB11",INI(1)))
- +15 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +16 SET @INV@("ZPL11")=X
- KILL DXS,D0
- +17 IF 'INVS
- DO MC^INHS
- +18 KILL LINE
- SET LINE=""
- SET CP=0
- SET L1="ZPL"
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,1,L1,.CP)
- SET L1=$GET(@INV@("ZPL1"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- +19 DO SETPIECE^INHU(.LINE,DELIM,2,L1,.CP)
- SET L1=$GET(@INV@("ZPL2"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,3,L1,.CP)
- SET L1=$GET(@INV@("ZPL3"))
- +20 IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,4,L1,.CP)
- SET L1=$GET(@INV@("ZPL4"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- +21 SET L1=$GET(@INV@("ZPL5"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,6,L1,.CP)
- SET L1=$GET(@INV@("ZPL6"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,7,L1,.CP)
- +22 SET L1=$GET(@INV@("ZPL7"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,8,L1,.CP)
- SET L1=$GET(@INV@("ZPL8"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,9,L1,.CP)
- +23 SET L1=$GET(@INV@("ZPL9"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,10,L1,.CP)
- SET L1=$GET(@INV@("ZPL10"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,11,L1,.CP)
- +24 SET L1=$GET(@INV@("ZPL11"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,12,L1,.CP)
- +25 SET LCT=LCT+1
- SET ^UTILITY("INH",$JOB,LCT)=LINE
- IF $DATA(LINE)>9
- MERGE ^UTILITY("INH",$JOB,LCT)=LINE
- +26 QUIT
- A1 SET INDA=INDA0
- KILL INDA0
- +1 SET INSETID=0
- +2 SET INDA0=INDA
- SET INI(1)=0
- FOR
- SET INI(1)=$ORDER(INDA("ZRF",INI(1)))
- IF 'INI(1)
- QUIT
- SET INDA=$SELECT(INDA("ZRF",INI(1)):INDA("ZRF",INI(1)),1:INI(1))
- Begin DoDot:1
- +3 ;SET ZRF1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF1
- +4 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF1",INI(1)))
- +5 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +6 SET @INV@("ZRF1")=X
- KILL DXS,D0
- +7 ;SET ZRF2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF2
- +8 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF2",INI(1)))
- +9 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +10 SET @INV@("ZRF2")=X
- KILL DXS,D0
- +11 ;SET ZRF3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF3
- +12 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF3",INI(1)))
- +13 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +14 SET @INV@("ZRF3")=X
- KILL DXS,D0
- +15 ;SET ZRF4 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF4
- +16 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF4",INI(1)))
- +17 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +18 SET @INV@("ZRF4")=X
- KILL DXS,D0
- +19 ;SET ZRF5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF5
- +20 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF5",INI(1)))
- +21 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +22 SET @INV@("ZRF5")=X
- KILL DXS,D0
- +23 ;SET ZRF6 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF6
- +24 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF6",INI(1)))
- +25 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +26 SET @INV@("ZRF6")=X
- KILL DXS,D0
- +27 ;SET ZRF7 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZRF7
- +28 SET D0=INDA
- SET X=$GET(INA("BDW1ZRF7",INI(1)))
- +29 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +30 SET @INV@("ZRF7")=X
- KILL DXS,D0
- +31 IF 'INVS
- DO MC^INHS
- +32 KILL LINE
- SET LINE=""
- SET CP=0
- SET L1="ZRF"
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,1,L1,.CP)
- SET L1=$GET(@INV@("ZRF1"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- +33 DO SETPIECE^INHU(.LINE,DELIM,2,L1,.CP)
- SET L1=$GET(@INV@("ZRF2"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,3,L1,.CP)
- SET L1=$GET(@INV@("ZRF3"))
- +34 IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,4,L1,.CP)
- SET L1=$GET(@INV@("ZRF4"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- +35 SET L1=$GET(@INV@("ZRF5"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,6,L1,.CP)
- SET L1=$GET(@INV@("ZRF6"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,7,L1,.CP)
- +36 SET L1=$GET(@INV@("ZRF7"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,8,L1,.CP)
- +37 SET LCT=LCT+1
- SET ^UTILITY("INH",$JOB,LCT)=LINE
- IF $DATA(LINE)>9
- MERGE ^UTILITY("INH",$JOB,LCT)=LINE
- +38 QUIT
- End DoDot:1
- +39 SET INDA=INDA0
- KILL INDA0
- +40 SET INSETID=0
- +41 SET INDA0=INDA
- SET INI(1)=0
- FOR
- SET INI(1)=$ORDER(INDA("ZMC",INI(1)))
- IF 'INI(1)
- QUIT
- SET INDA=$SELECT(INDA("ZMC",INI(1)):INDA("ZMC",INI(1)),1:INI(1))
- Begin DoDot:1
- +42 ;SET ZMC1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC1
- +43 SET D0=INDA
- SET X=$GET(INA("BDW1ZMC1",INI(1)))
- +44 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +45 SET @INV@("ZMC1")=X
- KILL DXS,D0
- +46 ;SET ZMC2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC2
- +47 SET D0=INDA
- SET X=$GET(INA("BDW1ZMC2",INI(1)))
- +48 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +49 SET @INV@("ZMC2")=X
- KILL DXS,D0
- +50 ;SET ZMC3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC3
- +51 SET D0=INDA
- SET X=$GET(INA("BDW1ZMC3",INI(1)))
- +52 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +53 SET @INV@("ZMC3")=X
- KILL DXS,D0
- +54 ;SET ZMC4 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC4
- +55 SET D0=INDA
- SET X=$GET(INA("BDW1ZMC4",INI(1)))
- +56 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +57 SET @INV@("ZMC4")=X
- KILL DXS,D0
- +58 ;SET ZMC5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1ZMC5
- +59 SET D0=INDA
- SET X=$GET(INA("BDW1ZMC5",INI(1)))
- +60 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +61 SET @INV@("ZMC5")=X
- KILL DXS,D0
- +62 IF 'INVS
- DO MC^INHS
- +63 KILL LINE
- SET LINE=""
- SET CP=0
- SET L1="ZMC"
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,1,L1,.CP)
- SET L1=$GET(@INV@("ZMC1"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- +64 DO SETPIECE^INHU(.LINE,DELIM,2,L1,.CP)
- SET L1=$GET(@INV@("ZMC2"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,3,L1,.CP)
- SET L1=$GET(@INV@("ZMC3"))
- +65 IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,4,L1,.CP)
- SET L1=$GET(@INV@("ZMC4"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,5,L1,.CP)
- +66 SET L1=$GET(@INV@("ZMC5"))
- IF $TRANSLATE(L1,$GET(SUBDELIM))=""
- SET L1=""
- DO SETPIECE^INHU(.LINE,DELIM,6,L1,.CP)
- +67 SET LCT=LCT+1
- SET ^UTILITY("INH",$JOB,LCT)=LINE
- IF $DATA(LINE)>9
- MERGE ^UTILITY("INH",$JOB,LCT)=LINE
- +68 QUIT
- End DoDot:1
- +69 SET INDA=INDA0
- KILL INDA0
- +70 SET INSETID=0
- +71 SET INDA0=INDA
- SET INI(1)=0
- FOR
- SET INI(1)=$ORDER(INDA("WHP",INI(1)))
- IF 'INI(1)
- QUIT
- SET INDA=$SELECT(INDA("WHP",INI(1)):INDA("WHP",INI(1)),1:INI(1))
- Begin DoDot:1
- +72 ;SET OBX1 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH1
- +73 SET D0=INDA
- SET X=$GET(INA("BDW1WH1",INI(1)))
- +74 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +75 SET @INV@("OBX1")=X
- KILL DXS,D0
- +76 ;SET OBX2 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH2
- +77 SET D0=INDA
- SET X=$GET(INA("BDW1WH2",INI(1)))
- +78 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +79 SET @INV@("OBX2")=X
- KILL DXS,D0
- +80 ;SET OBX3 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH3
- +81 SET D0=INDA
- SET X=$GET(INA("BDW1WH3",INI(1)))
- +82 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +83 SET @INV@("OBX3")=X
- KILL DXS,D0
- +84 ;SET OBX4 = ""
- +85 SET D0=INDA
- SET X=""
- +86 SET @INV@("OBX4")=X
- KILL DXS,D0
- +87 ;SET OBX5 = INSGX\^INTHL7FT(1,3)\\999\@BDW1WH5
- +88 SET D0=INDA
- SET X=$GET(INA("BDW1WH5",INI(1)))
- +89 SET X1="^INTHL7FT(1,3)"
- IF $LENGTH($GET(@X1))
- XECUTE $GET(@X1)
- SET X=$EXTRACT(X,1,999)
- +90 SET @INV@("OBX5")=X
- KILL DXS,D0
- +91 ;SET OBX6 = ""
- +92 SET D0=INDA
- SET X=""
- +93 SET @INV@("OBX6")=X
- KILL DXS,D0
- +94 ;SET OBX7 = ""
- +95 SET D0=INDA
- SET X=""
- +96 SET @INV@("OBX7")=X
- KILL DXS,D0
- +97 ;SET OBX8 = ""
- +98 SET D0=INDA
- SET X=""
- 9 DO EN^IS00031C
- End DoDot:1
- +1 GOTO D1^IS00031C
