- RMPR5N3 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/17/03 13:19
- ;;3.0;PROSTHETICS;**33,37,77**;Feb 09, 1996
- ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
- D DIV4^RMPRSIT I $D(Y),(Y<0) Q
- S X="NOW" D ^%DT D DD^%DT S RMDAT=Y
- ;
- EN K ^TMP($J),RMPRI,RMPRFLG S RMPREND=0 D HOME^%ZIS S DIC="^RMPR(661.1,",DIC(0)="AEQM",DIC("S")="I $D(^RMPR(661.1,+Y,0)),($P(^(0),U,9)=1)"
- EN1 R !!,"Enter 'ALL' for all HCPCS or 'RETURN' to select individual HCPCS: ",RMENTER:DTIME G:$D(DTOUT)!$D(DUOUT)!(RMENTER="^") EXIT1
- G:RMENTER["?" EN1
- S X=RMENTER X ^%ZOSF("UPPERCASE") S RMENTER=Y I RMENTER="ALL" S RMPRI(0)=1 G CONT
- SEL W ! F RML=1:1 S DIC("A")="Select HCPCS "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
- .S RMI=$P(^RMPR(661.1,+Y,0),U,1)
- .I $D(RMPRI(RMI)) W $C(7)," ??",?40,"..Duplicate HCPCS" S RML=RML-1 Q
- .S RMPRI(RMI)=+Y
- CONT G:'$D(RMPRI) EXIT1 S %ZIS="MQ" K IOP D ^%ZIS G:POP EXIT1 I '$D(IO("Q")) U IO G PRINT
- K IO("Q") S ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY",ZTRTN="PRINT^RMPR5N3",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
- D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT
- ;
- PRINT I $E(IOST)["C" W !!,"Processing report......."
- S RMPAGE=1,(RMTOBAL,RMPREND)=0,RS=RMPR("STA") M ^TMP($J,"RM")=RMPRI
- D:$D(RMPRI(0)) ALL
- I '$D(^TMP($J,"RM")) D NONE G EXIT
- S RB="" F S RB=$O(^TMP($J,"RM",RB)) Q:RB="" S RMLIEN=^TMP($J,"RM",RB) D
- .S J=0 F S J=$O(^RMPR(661.3,"C",RMLIEN,J)) Q:J'>0 S R63=$G(^RMPR(661.3,J,0)) I R63'="" S RMLO=$P(R63,U,1) S R3=$O(^RMPR(661.3,"C",RMLIEN,J,0)) I R3 D
- ..F R4=0:0 S R4=$O(^RMPR(661.3,J,1,R3,1,R4)) Q:R4'>0 Q:$P(R63,U,3)'=RS D
- ...S RM3=$G(^RMPR(661.3,J,1,R3,1,R4,0)) Q:RM3=""
- ...S RMIT=$P(RM3,U,1),RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2)
- ...S RMITEM=$P($G(^RMPR(661.1,RMLIEN,3,RMDAIT,0)),U,1) Q:RMITEM=""
- ...S RMUNI=$P(RM3,U,4),RMRLE=$P(RM3,U,6),RMDI=$P(RM3,U,7),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
- ...S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMVE=$P(RM3,U,5)
- ...S ^TMP($J,RB,RMITEM,RMLO)=RMAV_"^"_RMVE_"^^"_RMUNI_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMBA_"^"_RMCO
- W:$E(IOST)["C" @IOF
- D HEAD,WRI D:RMSUF TOTAL G EXIT
- ;write/print report
- WRI S RP="",RMSUF=0 D HEAD1
- F S RP=$O(^TMP($J,RP)) Q:(RP="")!(RMPREND) D:RMSUF TOTAL K RMPRFLG F S J=$O(^TMP($J,RP,J)) Q:(J="")!(RMPREND) S K="",RSA=RP F S K=$O(^TMP($J,RP,J,K)) Q:(K="")!(RMPREND) D
- .S RMAST="",RMTMP=^TMP($J,RP,J,K),RMVE=$P(RMTMP,U,2)
- .S RMUNI=$P(RMTMP,U,4),RMRLE=$P(RMTMP,U,5),RMDI=$P(RMTMP,U,6),RMSO=$P(RMTMP,U,7),RMBA=$P(RMTMP,U,8),RMCO=$P(RMTMP,U,9),RMAV=$P(RMTMP,U,1)
- .S RMITEM=J,RMLOC=K,RMSUF=1,RMTOBAL=RMTOBAL+RMBA
- .S:RMUNI RMUNI=$P(^PRCD(420.5,RMUNI,0),U,1)
- .S:RMVE RMVE=$P($G(^PRC(440,RMVE,0)),U,1)
- .S RMITEM=$E(RMITEM,1,20)
- .S:RMBA<RMRLE RMAST="*"
- .W !,RP,?9,RMITEM,?30,RMSO,?33,$E(RMLOC,1,8),?42,$E(RMVE,1,11),?55,RMUNI,?58,$J(RMRLE,4),?64,$J(RMAV,8,2),?73,$J(RMBA,5),RMAST
- .S RMPRFLG=1
- .I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD,HEAD1 Q
- .I $Y>(IOSL-6) W @IOF D HEAD,HEAD1 K RMPRFLG Q
- Q
- ;
- TOTAL W !,?71,"-------",!,?45,"Total ",RSA," balance = ",?71,$J(RMTOBAL,7),!,RMPR("L")
- S RMSUF=0,RMTOBAL=0
- Q
- ;
- HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***",?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT,?30,"station: ",$E($P($G(^DIC(4,RS,0)),U,1),1,20)
- S RMPAGE=RMPAGE+1
- Q
- ;
- HEAD1 I $E(IOST)["C"&($Y>(IOSL-7)) S DIR(0)="E" D ^DIR S:$D(DTOUT)!(Y=0) RMPREND=1 Q:RMPREND W @IOF D HEAD
- I $E(IOST)'["C"&($Y>(IOSL-6)) W @IOF D HEAD
- W !,RMPR("L")
- W !,?54,"UNIT",?60,"RE-"
- W !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
- W !,"HCPCS",?9,"ITEM",?29,"SRC",?33,"LOCATION",?42,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
- W !,"-----",?9,"----",?29,"---",?33,"--------",?42,"------",?53,"-----",?59,"-----",?68,"----",?75,"---"
- S RMPRFLG=1
- Q
- ;
- ALL ;process all items
- K RMPRI(0),^TMP($J,"RM")
- F I=0:0 S I=$O(^RMPR(661.1,I)) Q:I'>0 I $P(^RMPR(661.1,I,0),U,9)=1 S RMI=$P(^RMPR(661.1,I,0),U,1) S:RMI'="" ^TMP($J,"RM",RMI)=I
- Q
- ;
- EXIT I $E(IOST)["C",'RMPREND W ! S DIR(0)="E" D ^DIR
- EXIT1 D ^%ZISC
- N RMPR,RMPRSITE D KILL^XUSCLEAN
- Q
- NONE W !!,"NO DATA !!!!!"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR5N3 4227 printed Feb 18, 2025@23:59:40 Page 2
- RMPR5N3 ;HIN/RVD-PRINT INVENTORY BALANCE BY HCPCS ;3/17/03 13:19
- +1 ;;3.0;PROSTHETICS;**33,37,77**;Feb 09, 1996
- +2 ;RVD 3/17/03 patch #77 - allow queing to p-message. IO to ION.
- +3 DO DIV4^RMPRSIT
- IF $DATA(Y)
- IF (Y<0)
- QUIT
- +4 SET X="NOW"
- DO ^%DT
- DO DD^%DT
- SET RMDAT=Y
- +5 ;
- EN KILL ^TMP($JOB),RMPRI,RMPRFLG
- SET RMPREND=0
- DO HOME^%ZIS
- SET DIC="^RMPR(661.1,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $D(^RMPR(661.1,+Y,0)),($P(^(0),U,9)=1)"
- EN1 READ !!,"Enter 'ALL' for all HCPCS or 'RETURN' to select individual HCPCS: ",RMENTER:DTIME
- if $DATA(DTOUT)!$DATA(DUOUT)!(RMENTER="^")
- GOTO EXIT1
- +1 if RMENTER["?"
- GOTO EN1
- +2 SET X=RMENTER
- XECUTE ^%ZOSF("UPPERCASE")
- SET RMENTER=Y
- IF RMENTER="ALL"
- SET RMPRI(0)=1
- GOTO CONT
- SEL WRITE !
- FOR RML=1:1
- SET DIC("A")="Select HCPCS "_RML_": "
- DO ^DIC
- if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
- GOTO EXIT1
- if X=""
- QUIT
- Begin DoDot:1
- +1 SET RMI=$PIECE(^RMPR(661.1,+Y,0),U,1)
- +2 IF $DATA(RMPRI(RMI))
- WRITE $CHAR(7)," ??",?40,"..Duplicate HCPCS"
- SET RML=RML-1
- QUIT
- +3 SET RMPRI(RMI)=+Y
- End DoDot:1
- CONT if '$DATA(RMPRI)
- GOTO EXIT1
- SET %ZIS="MQ"
- KILL IOP
- DO ^%ZIS
- if POP
- GOTO EXIT1
- IF '$DATA(IO("Q"))
- USE IO
- GOTO PRINT
- +1 KILL IO("Q")
- SET ZTDESC="PROSTHETIC INVENTORY LOCATION SUMMARY"
- SET ZTRTN="PRINT^RMPR5N3"
- SET ZTIO=ION
- SET ZTSAVE("RMPRI(")=""
- SET ZTSAVE("RMPR(""STA"")")=""
- SET ZTSAVE("RMDAT")=""
- SET ZTSAVE("RMPR(")=""
- +2 DO ^%ZTLOAD
- if $DATA(ZTSK)
- WRITE !,"REQUEST QUEUED!"
- HANG 1
- GOTO EXIT
- +3 ;
- PRINT IF $EXTRACT(IOST)["C"
- WRITE !!,"Processing report......."
- +1 SET RMPAGE=1
- SET (RMTOBAL,RMPREND)=0
- SET RS=RMPR("STA")
- MERGE ^TMP($JOB,"RM")=RMPRI
- +2 if $DATA(RMPRI(0))
- DO ALL
- +3 IF '$DATA(^TMP($JOB,"RM"))
- DO NONE
- GOTO EXIT
- +4 SET RB=""
- FOR
- SET RB=$ORDER(^TMP($JOB,"RM",RB))
- if RB=""
- QUIT
- SET RMLIEN=^TMP($JOB,"RM",RB)
- Begin DoDot:1
- +5 SET J=0
- FOR
- SET J=$ORDER(^RMPR(661.3,"C",RMLIEN,J))
- if J'>0
- QUIT
- SET R63=$GET(^RMPR(661.3,J,0))
- IF R63'=""
- SET RMLO=$PIECE(R63,U,1)
- SET R3=$ORDER(^RMPR(661.3,"C",RMLIEN,J,0))
- IF R3
- Begin DoDot:2
- +6 FOR R4=0:0
- SET R4=$ORDER(^RMPR(661.3,J,1,R3,1,R4))
- if R4'>0
- QUIT
- if $PIECE(R63,U,3)'=RS
- QUIT
- Begin DoDot:3
- +7 SET RM3=$GET(^RMPR(661.3,J,1,R3,1,R4,0))
- if RM3=""
- QUIT
- +8 SET RMIT=$PIECE(RM3,U,1)
- SET RMHCPC=$PIECE(RMIT,"-",1)
- SET RMDAIT=$PIECE(RMIT,"-",2)
- +9 SET RMITEM=$PIECE($GET(^RMPR(661.1,RMLIEN,3,RMDAIT,0)),U,1)
- if RMITEM=""
- QUIT
- +10 SET RMUNI=$PIECE(RM3,U,4)
- SET RMRLE=$PIECE(RM3,U,6)
- SET RMDI=$PIECE(RM3,U,7)
- SET RMSO=$PIECE(RM3,U,9)
- SET RMAV=$PIECE(RM3,U,10)
- +11 SET RMBA=$PIECE(RM3,U,2)
- SET RMCO=$PIECE(RM3,U,3)
- SET RMVE=$PIECE(RM3,U,5)
- +12 SET ^TMP($JOB,RB,RMITEM,RMLO)=RMAV_"^"_RMVE_"^^"_RMUNI_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMBA_"^"_RMCO
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +13 if $EXTRACT(IOST)["C"
- WRITE @IOF
- +14 DO HEAD
- DO WRI
- if RMSUF
- DO TOTAL
- GOTO EXIT
- +15 ;write/print report
- WRI SET RP=""
- SET RMSUF=0
- DO HEAD1
- +1 FOR
- SET RP=$ORDER(^TMP($JOB,RP))
- if (RP="")!(RMPREND)
- QUIT
- if RMSUF
- DO TOTAL
- KILL RMPRFLG
- FOR
- SET J=$ORDER(^TMP($JOB,RP,J))
- if (J="")!(RMPREND)
- QUIT
- SET K=""
- SET RSA=RP
- FOR
- SET K=$ORDER(^TMP($JOB,RP,J,K))
- if (K="")!(RMPREND)
- QUIT
- Begin DoDot:1
- +2 SET RMAST=""
- SET RMTMP=^TMP($JOB,RP,J,K)
- SET RMVE=$PIECE(RMTMP,U,2)
- +3 SET RMUNI=$PIECE(RMTMP,U,4)
- SET RMRLE=$PIECE(RMTMP,U,5)
- SET RMDI=$PIECE(RMTMP,U,6)
- SET RMSO=$PIECE(RMTMP,U,7)
- SET RMBA=$PIECE(RMTMP,U,8)
- SET RMCO=$PIECE(RMTMP,U,9)
- SET RMAV=$PIECE(RMTMP,U,1)
- +4 SET RMITEM=J
- SET RMLOC=K
- SET RMSUF=1
- SET RMTOBAL=RMTOBAL+RMBA
- +5 if RMUNI
- SET RMUNI=$PIECE(^PRCD(420.5,RMUNI,0),U,1)
- +6 if RMVE
- SET RMVE=$PIECE($GET(^PRC(440,RMVE,0)),U,1)
- +7 SET RMITEM=$EXTRACT(RMITEM,1,20)
- +8 if RMBA<RMRLE
- SET RMAST="*"
- +9 WRITE !,RP,?9,RMITEM,?30,RMSO,?33,$EXTRACT(RMLOC,1,8),?42,$EXTRACT(RMVE,1,11),?55,RMUNI,?58,$JUSTIFY(RMRLE,4),?64,$JUSTIFY(RMAV,8,2),?73,$JUSTIFY(RMBA,5),RMAST
- +10 SET RMPRFLG=1
- +11 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!(Y=0)
- SET RMPREND=1
- if RMPREND
- QUIT
- WRITE @IOF
- DO HEAD
- DO HEAD1
- QUIT
- +12 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HEAD
- DO HEAD1
- KILL RMPRFLG
- QUIT
- End DoDot:1
- +13 QUIT
- +14 ;
- TOTAL WRITE !,?71,"-------",!,?45,"Total ",RSA," balance = ",?71,$JUSTIFY(RMTOBAL,7),!,RMPR("L")
- +1 SET RMSUF=0
- SET RMTOBAL=0
- +2 QUIT
- +3 ;
- HEAD WRITE !,"*** PROSTHETICS INVENTORY BALANCE BY HCPCS ***",?68,"PAGE: ",RMPAGE,!,"Run Date: ",RMDAT,?30,"station: ",$EXTRACT($PIECE($GET(^DIC(4,RS,0)),U,1),1,20)
- +1 SET RMPAGE=RMPAGE+1
- +2 QUIT
- +3 ;
- HEAD1 IF $EXTRACT(IOST)["C"&($Y>(IOSL-7))
- SET DIR(0)="E"
- DO ^DIR
- if $DATA(DTOUT)!(Y=0)
- SET RMPREND=1
- if RMPREND
- QUIT
- WRITE @IOF
- DO HEAD
- +1 IF $EXTRACT(IOST)'["C"&($Y>(IOSL-6))
- WRITE @IOF
- DO HEAD
- +2 WRITE !,RMPR("L")
- +3 WRITE !,?54,"UNIT",?60,"RE-"
- +4 WRITE !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
- +5 WRITE !,"HCPCS",?9,"ITEM",?29,"SRC",?33,"LOCATION",?42,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
- +6 WRITE !,"-----",?9,"----",?29,"---",?33,"--------",?42,"------",?53,"-----",?59,"-----",?68,"----",?75,"---"
- +7 SET RMPRFLG=1
- +8 QUIT
- +9 ;
- ALL ;process all items
- +1 KILL RMPRI(0),^TMP($JOB,"RM")
- +2 FOR I=0:0
- SET I=$ORDER(^RMPR(661.1,I))
- if I'>0
- QUIT
- IF $PIECE(^RMPR(661.1,I,0),U,9)=1
- SET RMI=$PIECE(^RMPR(661.1,I,0),U,1)
- if RMI'=""
- SET ^TMP($JOB,"RM",RMI)=I
- +3 QUIT
- +4 ;
- EXIT IF $EXTRACT(IOST)["C"
- IF 'RMPREND
- WRITE !
- SET DIR(0)="E"
- DO ^DIR
- EXIT1 DO ^%ZISC
- +1 NEW RMPR,RMPRSITE
- DO KILL^XUSCLEAN
- +2 QUIT
- NONE WRITE !!,"NO DATA !!!!!"
- +1 QUIT
