- RMPR5HQ5 ;HCIOFO/ODJ - INVENTORY REPORT - BUILD ^TMP SORT ARRAY ; 20 SEP 00
- ;;3.0;PROSTHETICS;**51,61,127**;Feb 09, 1996
- ;
- ;RVD -patch #61 - modified to read the new PIP files; 661.11, 661.6
- ; 661.7, 661.9
- Q
- ;
- ; Start of Report build and print. Enter here after report params.
- ; entered by user (see RMPR5HQ4).
- ; Also called by TaskMan if report queued.
- ;
- ; Variables required
- ;
- ; RMPR("STA")
- ; RMPRSDT
- ; RMPREDT
- ; RMPRDET
- ; RMPRSEL
- ; {IO vars}
- ;
- REPORT I $E(IOST)["C" W !!,"Processing report......."
- D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPR("STA")) ;generate ^TMP sort array
- D CALC^RMPR5HQ6 ;calculations
- U IO D ^RMPR5HQ2 ;print report
- D ^%ZISC
- ;K ^TMP($J,"RMPR5") ;make live after testing
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- Q
- ;
- ; Entry point for national roll-up
- NATION N RMPRSEL,RMPRDET,RMPRSTN,RMPRSDT,RMPREDT,X,RSTN
- S RMPRSTN="*"
- S RMPRDET="H"
- ;D NOW^%DTC S RMPREDT=X S %H=%H-30 D YMD^%DTC S RMPRSDT=X
- S RMPRSDT=RMPRPIP1,RMPREDT=RMPRPIP2
- S RMPRSEL("*")=""
- D GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPRSTN)
- D CALC^RMPR5HQ6 ;put calcs in TMP array
- D MAIL^RMPR5HQ7 ;build ^TMP($J,"RMPR5A" array for mailing
- Q
- ;
- ;
- ; Generate temporary index global ^TMP($J,"RMPR5"
- ; (as of 11/29/00 we use the 660 file, not 661.2)
- ;
- GEN(STDT,ENDT,DETAIL,RMPRSEL,RMPRSTN) ;
- N TNAM,FROM,EOF,DAT,HCDAT,HCPCIEN,NPGRP,NPLIN,S,HCPC,HCPCITEM
- N OUPIEN,ITEM,ALLGRP,HCPCREF,SELECTED,STATION,QTY,STR,MULITEM
- N ITMIEN,INVDT,SOURCE,ISCOST,PATIENT,COST
- S TNAM="RMPR5" ;TMP global name
- K ^TMP($J,TNAM)
- D CURVAL(TNAM,RMPRSTN,.RMPRSEL,DETAIL)
- ;S FROM="" S:$G(STDT)'="*" FROM=STDT-1
- S RSTN=RMPRSTN
- S:RMPRSTN="*" RSTN=0
- S EOF=0,ENDT=ENDT+1
- F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.6,"XSTD",RSTN)) Q:RSTN'>0 D
- .F RSDT=STDT:0 S RSDT=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT)) Q:(RSDT>ENDT)!(RSDT="") D Q:EOF
- .. S OUPIEN=0
- .. F S OUPIEN=$O(^RMPR(661.6,"XSTD",RSTN,3,RSDT,OUPIEN)) Q:OUPIEN'>0 D
- ... S S=$G(^RMPR(661.6,OUPIEN,0))
- ... S PATIENT=$P(S,"^",2) Q:PATIENT=""
- ... S QTY=+$P(S,"^",5) Q:QTY<1
- ... S HCPC=$P(S,"^",1) Q:HCPC=""
- ... S HCPCIEN=$O(^RMPR(661.1,"B",HCPC,0)) Q:HCPCIEN=""
- ... S STATION=RSTN Q:STATION=""
- ... I RMPRSTN'="*",STATION'=RSTN Q
- ... Q:'$D(^TMP($J,TNAM,"Z",HCPCIEN))
- ... Q:$P(^TMP($J,TNAM,"Z",HCPCIEN),"^",3)=1
- ... S HCPCITEM=HCPC_"-"_$P(S,"^",11)
- ... S ITEM=$P(HCPCITEM,"-",2)
- ... S:ITEM="" ITEM="?"
- ... S ISCOST=$P(S,"^",6)
- ...; S COST=$$PRECOST(OUPIEN,HCPCIEN,HCPCITEM,STATION)
- ...; I COST'="" S ISCOST=COST-ISCOST
- ...; S:COST="" ISCOST=QTY*$P(S,"^",5)
- ... S R11=$O(^RMPR(661.11,"C",HCPCITEM,0))
- ... S R11DAT=$G(^RMPR(661.11,R11,0))
- ... S SOURCE=$P(R11DAT,"^",5)
- ... S STR=^TMP($J,TNAM,"Z",HCPCIEN)
- ... S NPGRP=$P(STR,"^",1)
- ... S NPLIN=$P(STR,"^",2)
- ... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
- ... I '$D(^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)) D Q:'+QTY
- .... S:+QTY ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)=""
- .... Q
- ... S ^TMP($J,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM,OUPIEN)=QTY_"^"_ISCOST_"^"_SOURCE
- ... Q
- .. Q
- Q
- ;
- ; Get total cost of item just prior to current issue
- PRECOST(INVIEN,HCPCIEN,HCPCITEM,STATION) ;
- N IEN,COST,STR,LOC
- S COST=""
- S IEN=INVIEN,RD=RMPRSDT
- S RD=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD),-1)
- Q:'$G(RD) COST S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD,0))
- S STR=^RMPR(661.9,RIEN,0)
- S COST=$P(STR,"^",9)
- Q COST
- ;
- ; Get QOH for HCPC
- CURVAL(RMPRNAM,RMPRSTN,RMPRSEL,DETAIL) ;
- N INVIEN,STR,IEN1,IEN2,LOCN,HCPCIEN,HCDAT,NPLIN,NPGRP,ALLGRP,SELECTED
- N S,SOURCE,STATION,QOH,COST,HCPC,HCPCREF,ITEM,RSTN
- S ALLGRP=0 S:$O(RMPRSEL(""))="*" ALLGRP=1
- S RSTN=RMPRSTN
- S:RMPRSTN="*" RSTN=0
- F RSTN=RSTN:0 S RSTN=$O(^RMPR(661.9,"ASHID",RSTN)) Q:RSTN'>0 D
- .S RH=""
- .F S RH=$O(^RMPR(661.9,"ASHID",RSTN,RH)) Q:RH="" D
- .. S IEN1=0
- .. F S IEN1=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1)) Q:'+IEN1 D
- ... S HCPCIEN=$O(^RMPR(661.1,"B",RH,0)) Q:HCPCIEN=""
- ... I '$D(^TMP($J,RMPRNAM,"Z",HCPCIEN)) D
- .... S S=^RMPR(661.1,HCPCIEN,0)
- .... S NPLIN=$P(S,"^",7)
- .... S:NPLIN="" NPLIN="999 X"
- .... S NPGRP=$P(NPLIN," ",1) ;group num. is 1st set of digits of new line
- .... S STR=NPGRP
- .... S $P(STR,"^",2)=NPLIN
- .... S ^TMP($J,RMPRNAM,"Z",HCPCIEN)=STR
- .... Q
- ... E D Q:$P(S,"^",3)=1
- .... S S=^TMP($J,RMPRNAM,"Z",HCPCIEN)
- .... S NPGRP=$P(S,"^",1)
- .... S NPLIN=$P(S,"^",2)
- .... Q
- ... ;
- ... ; Test if record matches selection criteria
- ... ; (only needed if not all groups selected)
- ... I 'ALLGRP D I 'SELECTED S $P(^TMP($J,RMPRNAM,"Z",HCPCIEN),"^",3)=1 Q
- .... S SELECTED=0
- .... I '$D(RMPRSEL(NPGRP)) Q
- .... I DETAIL="G" S SELECTED=1 Q
- .... I $O(RMPRSEL(NPGRP,""))="*" S SELECTED=1 Q
- .... I '$D(RMPRSEL(NPGRP,NPLIN)) Q
- .... I DETAIL="L" S SELECTED=1 Q
- .... I $O(RMPRSEL(NPGRP,NPLIN,""))="*" S SELECTED=1 Q
- .... I '$D(RMPRSEL(NPGRP,NPLIN,HCPCIEN)) Q
- .... S SELECTED=1
- .... Q
- ... S RD=ENDT+1
- ... S RD=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD),-1) Q:RD="" S RIEN=$O(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD,""),-1) D
- .... S HCPC=RH,S=^RMPR(661.9,RIEN,0)
- .... S QOH=+$P(S,"^",8) Q:'QOH
- .... S COST=$P(S,"^",9)
- .... S ITEM=IEN1
- .... S RS=$O(^RMPR(661.11,"C",HCPC_"-"_ITEM,0)) Q:RS=""
- .... S SOURCE=$P($G(^RMPR(661.11,RS,0)),U,5)
- .... S HCPCREF=HCPC,$P(HCPCREF,"/",2)=HCPCIEN
- .... S S=$G(^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM))
- .... I SOURCE="C" D
- ..... S $P(S,"^",9)=QOH+$P(S,"^",9)
- ..... S $P(S,"^",11)=COST+$P(S,"^",11)
- ..... Q
- .... E D
- ..... S $P(S,"^",8)=QOH+$P(S,"^",8)
- ..... S $P(S,"^",10)=COST+$P(S,"^",10)
- ..... Q
- .... S ^TMP($J,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM)=S
- .... Q
- ... Q
- .. Q
- Q
- ;
- ; return item text string given HCPC and ITEM IENs to 661.11
- ; if null ITEMIEN passed the just return the HCPC short name text
- GETITEM(HCPCIEN,ITEMIEN) ;
- N STR,ITEMTXT
- S ITEMTXT=""
- I ITEMIEN="" D G GETITEMX
- . S STR=$G(^RMPR(661.1,HCPCIEN,0))
- . S ITEMTXT=$P(STR,"^",2)
- . Q
- S HCPC=$P($G(^RMPR(661.1,HCPCIEN,0)),U,1)
- S STR=$G(^RMPR(661.11,"C",HCPC_"-"_ITEMIEN,0))
- I STR="" D
- . S ITEMTXT=$P(^RMPR(661.1,HCPCIEN,0),"^",2)
- . Q
- E D
- . S ITEMTXT=$P(STR,"^",1)
- . Q
- S:ITEMTXT="" ITEMTXT="ITEM "_ITEMIEN
- GETITEMX Q ITEMTXT
- ;
- ; return NPPD line text from line code (New lines only)
- NPLIN(CODE) ;
- N I,S,LINTXT
- S LINTXT=""
- F I=1:1 S S=$P($T(DES+I^RMPRN62),";;",2) Q:$E(S,1,3)="END" D Q:LINTXT'=""
- . I $P(S,";",1)=CODE S LINTXT=$P(S,";",2)
- . Q
- Q LINTXT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5HQ5 6521 printed Jan 18, 2025@03:34:10 Page 2
- RMPR5HQ5 ;HCIOFO/ODJ - INVENTORY REPORT - BUILD ^TMP SORT ARRAY ; 20 SEP 00
- +1 ;;3.0;PROSTHETICS;**51,61,127**;Feb 09, 1996
- +2 ;
- +3 ;RVD -patch #61 - modified to read the new PIP files; 661.11, 661.6
- +4 ; 661.7, 661.9
- +5 QUIT
- +6 ;
- +7 ; Start of Report build and print. Enter here after report params.
- +8 ; entered by user (see RMPR5HQ4).
- +9 ; Also called by TaskMan if report queued.
- +10 ;
- +11 ; Variables required
- +12 ;
- +13 ; RMPR("STA")
- +14 ; RMPRSDT
- +15 ; RMPREDT
- +16 ; RMPRDET
- +17 ; RMPRSEL
- +18 ; {IO vars}
- +19 ;
- REPORT IF $EXTRACT(IOST)["C"
- WRITE !!,"Processing report......."
- +1 ;generate ^TMP sort array
- DO GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPR("STA"))
- +2 ;calculations
- DO CALC^RMPR5HQ6
- +3 ;print report
- USE IO
- DO ^RMPR5HQ2
- +4 DO ^%ZISC
- +5 ;K ^TMP($J,"RMPR5") ;make live after testing
- +6 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +7 QUIT
- +8 ;
- +9 ; Entry point for national roll-up
- NATION NEW RMPRSEL,RMPRDET,RMPRSTN,RMPRSDT,RMPREDT,X,RSTN
- +1 SET RMPRSTN="*"
- +2 SET RMPRDET="H"
- +3 ;D NOW^%DTC S RMPREDT=X S %H=%H-30 D YMD^%DTC S RMPRSDT=X
- +4 SET RMPRSDT=RMPRPIP1
- SET RMPREDT=RMPRPIP2
- +5 SET RMPRSEL("*")=""
- +6 DO GEN(RMPRSDT,RMPREDT,RMPRDET,.RMPRSEL,RMPRSTN)
- +7 ;put calcs in TMP array
- DO CALC^RMPR5HQ6
- +8 ;build ^TMP($J,"RMPR5A" array for mailing
- DO MAIL^RMPR5HQ7
- +9 QUIT
- +10 ;
- +11 ;
- +12 ; Generate temporary index global ^TMP($J,"RMPR5"
- +13 ; (as of 11/29/00 we use the 660 file, not 661.2)
- +14 ;
- GEN(STDT,ENDT,DETAIL,RMPRSEL,RMPRSTN) ;
- +1 NEW TNAM,FROM,EOF,DAT,HCDAT,HCPCIEN,NPGRP,NPLIN,S,HCPC,HCPCITEM
- +2 NEW OUPIEN,ITEM,ALLGRP,HCPCREF,SELECTED,STATION,QTY,STR,MULITEM
- +3 NEW ITMIEN,INVDT,SOURCE,ISCOST,PATIENT,COST
- +4 ;TMP global name
- SET TNAM="RMPR5"
- +5 KILL ^TMP($JOB,TNAM)
- +6 DO CURVAL(TNAM,RMPRSTN,.RMPRSEL,DETAIL)
- +7 ;S FROM="" S:$G(STDT)'="*" FROM=STDT-1
- +8 SET RSTN=RMPRSTN
- +9 if RMPRSTN="*"
- SET RSTN=0
- +10 SET EOF=0
- SET ENDT=ENDT+1
- +11 FOR RSTN=RSTN:0
- SET RSTN=$ORDER(^RMPR(661.6,"XSTD",RSTN))
- if RSTN'>0
- QUIT
- Begin DoDot:1
- +12 FOR RSDT=STDT:0
- SET RSDT=$ORDER(^RMPR(661.6,"XSTD",RSTN,3,RSDT))
- if (RSDT>ENDT)!(RSDT="")
- QUIT
- Begin DoDot:2
- +13 SET OUPIEN=0
- +14 FOR
- SET OUPIEN=$ORDER(^RMPR(661.6,"XSTD",RSTN,3,RSDT,OUPIEN))
- if OUPIEN'>0
- QUIT
- Begin DoDot:3
- +15 SET S=$GET(^RMPR(661.6,OUPIEN,0))
- +16 SET PATIENT=$PIECE(S,"^",2)
- if PATIENT=""
- QUIT
- +17 SET QTY=+$PIECE(S,"^",5)
- if QTY<1
- QUIT
- +18 SET HCPC=$PIECE(S,"^",1)
- if HCPC=""
- QUIT
- +19 SET HCPCIEN=$ORDER(^RMPR(661.1,"B",HCPC,0))
- if HCPCIEN=""
- QUIT
- +20 SET STATION=RSTN
- if STATION=""
- QUIT
- +21 IF RMPRSTN'="*"
- IF STATION'=RSTN
- QUIT
- +22 if '$DATA(^TMP($JOB,TNAM,"Z",HCPCIEN))
- QUIT
- +23 if $PIECE(^TMP($JOB,TNAM,"Z",HCPCIEN),"^",3)=1
- QUIT
- +24 SET HCPCITEM=HCPC_"-"_$PIECE(S,"^",11)
- +25 SET ITEM=$PIECE(HCPCITEM,"-",2)
- +26 if ITEM=""
- SET ITEM="?"
- +27 SET ISCOST=$PIECE(S,"^",6)
- +28 ; S COST=$$PRECOST(OUPIEN,HCPCIEN,HCPCITEM,STATION)
- +29 ; I COST'="" S ISCOST=COST-ISCOST
- +30 ; S:COST="" ISCOST=QTY*$P(S,"^",5)
- +31 SET R11=$ORDER(^RMPR(661.11,"C",HCPCITEM,0))
- +32 SET R11DAT=$GET(^RMPR(661.11,R11,0))
- +33 SET SOURCE=$PIECE(R11DAT,"^",5)
- +34 SET STR=^TMP($JOB,TNAM,"Z",HCPCIEN)
- +35 SET NPGRP=$PIECE(STR,"^",1)
- +36 SET NPLIN=$PIECE(STR,"^",2)
- +37 SET HCPCREF=HCPC
- SET $PIECE(HCPCREF,"/",2)=HCPCIEN
- +38 IF '$DATA(^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM))
- Begin DoDot:4
- +39 if +QTY
- SET ^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM)=""
- +40 QUIT
- End DoDot:4
- if '+QTY
- QUIT
- +41 SET ^TMP($JOB,TNAM,STATION,NPGRP,NPLIN,HCPCREF,ITEM,OUPIEN)=QTY_"^"_ISCOST_"^"_SOURCE
- +42 QUIT
- End DoDot:3
- +43 QUIT
- End DoDot:2
- if EOF
- QUIT
- End DoDot:1
- +44 QUIT
- +45 ;
- +46 ; Get total cost of item just prior to current issue
- PRECOST(INVIEN,HCPCIEN,HCPCITEM,STATION) ;
- +1 NEW IEN,COST,STR,LOC
- +2 SET COST=""
- +3 SET IEN=INVIEN
- SET RD=RMPRSDT
- +4 SET RD=$ORDER(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD),-1)
- +5 if '$GET(RD)
- QUIT COST
- SET RIEN=$ORDER(^RMPR(661.9,"ASHID",RSTN,HCPC,IEN,RD,0))
- +6 SET STR=^RMPR(661.9,RIEN,0)
- +7 SET COST=$PIECE(STR,"^",9)
- +8 QUIT COST
- +9 ;
- +10 ; Get QOH for HCPC
- CURVAL(RMPRNAM,RMPRSTN,RMPRSEL,DETAIL) ;
- +1 NEW INVIEN,STR,IEN1,IEN2,LOCN,HCPCIEN,HCDAT,NPLIN,NPGRP,ALLGRP,SELECTED
- +2 NEW S,SOURCE,STATION,QOH,COST,HCPC,HCPCREF,ITEM,RSTN
- +3 SET ALLGRP=0
- if $ORDER(RMPRSEL(""))="*"
- SET ALLGRP=1
- +4 SET RSTN=RMPRSTN
- +5 if RMPRSTN="*"
- SET RSTN=0
- +6 FOR RSTN=RSTN:0
- SET RSTN=$ORDER(^RMPR(661.9,"ASHID",RSTN))
- if RSTN'>0
- QUIT
- Begin DoDot:1
- +7 SET RH=""
- +8 FOR
- SET RH=$ORDER(^RMPR(661.9,"ASHID",RSTN,RH))
- if RH=""
- QUIT
- Begin DoDot:2
- +9 SET IEN1=0
- +10 FOR
- SET IEN1=$ORDER(^RMPR(661.9,"ASHID",RSTN,RH,IEN1))
- if '+IEN1
- QUIT
- Begin DoDot:3
- +11 SET HCPCIEN=$ORDER(^RMPR(661.1,"B",RH,0))
- if HCPCIEN=""
- QUIT
- +12 IF '$DATA(^TMP($JOB,RMPRNAM,"Z",HCPCIEN))
- Begin DoDot:4
- +13 SET S=^RMPR(661.1,HCPCIEN,0)
- +14 SET NPLIN=$PIECE(S,"^",7)
- +15 if NPLIN=""
- SET NPLIN="999 X"
- +16 ;group num. is 1st set of digits of new line
- SET NPGRP=$PIECE(NPLIN," ",1)
- +17 SET STR=NPGRP
- +18 SET $PIECE(STR,"^",2)=NPLIN
- +19 SET ^TMP($JOB,RMPRNAM,"Z",HCPCIEN)=STR
- +20 QUIT
- End DoDot:4
- +21 IF '$TEST
- Begin DoDot:4
- +22 SET S=^TMP($JOB,RMPRNAM,"Z",HCPCIEN)
- +23 SET NPGRP=$PIECE(S,"^",1)
- +24 SET NPLIN=$PIECE(S,"^",2)
- +25 QUIT
- End DoDot:4
- if $PIECE(S,"^",3)=1
- QUIT
- +26 ;
- +27 ; Test if record matches selection criteria
- +28 ; (only needed if not all groups selected)
- +29 IF 'ALLGRP
- Begin DoDot:4
- +30 SET SELECTED=0
- +31 IF '$DATA(RMPRSEL(NPGRP))
- QUIT
- +32 IF DETAIL="G"
- SET SELECTED=1
- QUIT
- +33 IF $ORDER(RMPRSEL(NPGRP,""))="*"
- SET SELECTED=1
- QUIT
- +34 IF '$DATA(RMPRSEL(NPGRP,NPLIN))
- QUIT
- +35 IF DETAIL="L"
- SET SELECTED=1
- QUIT
- +36 IF $ORDER(RMPRSEL(NPGRP,NPLIN,""))="*"
- SET SELECTED=1
- QUIT
- +37 IF '$DATA(RMPRSEL(NPGRP,NPLIN,HCPCIEN))
- QUIT
- +38 SET SELECTED=1
- +39 QUIT
- End DoDot:4
- IF 'SELECTED
- SET $PIECE(^TMP($JOB,RMPRNAM,"Z",HCPCIEN),"^",3)=1
- QUIT
- +40 SET RD=ENDT+1
- +41 SET RD=$ORDER(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD),-1)
- if RD=""
- QUIT
- SET RIEN=$ORDER(^RMPR(661.9,"ASHID",RSTN,RH,IEN1,RD,""),-1)
- Begin DoDot:4
- +42 SET HCPC=RH
- SET S=^RMPR(661.9,RIEN,0)
- +43 SET QOH=+$PIECE(S,"^",8)
- if 'QOH
- QUIT
- +44 SET COST=$PIECE(S,"^",9)
- +45 SET ITEM=IEN1
- +46 SET RS=$ORDER(^RMPR(661.11,"C",HCPC_"-"_ITEM,0))
- if RS=""
- QUIT
- +47 SET SOURCE=$PIECE($GET(^RMPR(661.11,RS,0)),U,5)
- +48 SET HCPCREF=HCPC
- SET $PIECE(HCPCREF,"/",2)=HCPCIEN
- +49 SET S=$GET(^TMP($JOB,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM))
- +50 IF SOURCE="C"
- Begin DoDot:5
- +51 SET $PIECE(S,"^",9)=QOH+$PIECE(S,"^",9)
- +52 SET $PIECE(S,"^",11)=COST+$PIECE(S,"^",11)
- +53 QUIT
- End DoDot:5
- +54 IF '$TEST
- Begin DoDot:5
- +55 SET $PIECE(S,"^",8)=QOH+$PIECE(S,"^",8)
- +56 SET $PIECE(S,"^",10)=COST+$PIECE(S,"^",10)
- +57 QUIT
- End DoDot:5
- +58 SET ^TMP($JOB,RMPRNAM,RSTN,NPGRP,NPLIN,HCPCREF,ITEM)=S
- +59 QUIT
- End DoDot:4
- +60 QUIT
- End DoDot:3
- +61 QUIT
- End DoDot:2
- End DoDot:1
- +62 QUIT
- +63 ;
- +64 ; return item text string given HCPC and ITEM IENs to 661.11
- +65 ; if null ITEMIEN passed the just return the HCPC short name text
- GETITEM(HCPCIEN,ITEMIEN) ;
- +1 NEW STR,ITEMTXT
- +2 SET ITEMTXT=""
- +3 IF ITEMIEN=""
- Begin DoDot:1
- +4 SET STR=$GET(^RMPR(661.1,HCPCIEN,0))
- +5 SET ITEMTXT=$PIECE(STR,"^",2)
- +6 QUIT
- End DoDot:1
- GOTO GETITEMX
- +7 SET HCPC=$PIECE($GET(^RMPR(661.1,HCPCIEN,0)),U,1)
- +8 SET STR=$GET(^RMPR(661.11,"C",HCPC_"-"_ITEMIEN,0))
- +9 IF STR=""
- Begin DoDot:1
- +10 SET ITEMTXT=$PIECE(^RMPR(661.1,HCPCIEN,0),"^",2)
- +11 QUIT
- End DoDot:1
- +12 IF '$TEST
- Begin DoDot:1
- +13 SET ITEMTXT=$PIECE(STR,"^",1)
- +14 QUIT
- End DoDot:1
- +15 if ITEMTXT=""
- SET ITEMTXT="ITEM "_ITEMIEN
- GETITEMX QUIT ITEMTXT
- +1 ;
- +2 ; return NPPD line text from line code (New lines only)
- NPLIN(CODE) ;
- +1 NEW I,S,LINTXT
- +2 SET LINTXT=""
- +3 FOR I=1:1
- SET S=$PIECE($TEXT(DES+I^RMPRN62),";;",2)
- if $EXTRACT(S,1,3)="END"
- QUIT
- Begin DoDot:1
- +4 IF $PIECE(S,";",1)=CODE
- SET LINTXT=$PIECE(S,";",2)
- +5 QUIT
- End DoDot:1
- if LINTXT'=""
- QUIT
- +6 QUIT LINTXT