- RMPR5N2 ;HIN/RVD-PRINT INVENTORY BALANCE BY LOCATION ;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.3,",DIC(0)="AEQ",DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- EN1 R !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",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
- W ! F RML=1:1 S DIC("A")="Select Location "_RML_": " D ^DIC G:$D(DTOUT)!(X["^")!(X=""&(RML=1)) EXIT1 Q:X="" D
- .S RMLOCI=$P(^RMPR(661.3,+Y,0),U,1)
- .I $D(RMPRI(RMLOCI)) W $C(7)," ??",?40,"..Duplicate Location" S RML=RML-1 Q
- .S RMPRI(RMLOCI)=+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^RMPR5N2",ZTIO=ION,ZTSAVE("RMPRI(")="",ZTSAVE("RMPR(""STA"")")="",ZTSAVE("RMDAT")="",ZTSAVE("RMPR(")=""
- D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!" H 1 G EXIT1
- ;
- PRINT I $E(IOST)["C" W !!,"Processing report....."
- S RMPAGE=1,RMPREND=0,RS=RMPR("STA") D:$D(RMPRI(0)) ALL
- I '$D(RMPRI) D NONE G EXIT
- C S RB="" F S RB=$O(RMPRI(RB)) Q:RB="" Q:RMPREND S RMLIEN=RMPRI(RB) D CK
- G:RMPREND EXIT
- W:$E(IOST)["C" @IOF
- D HEAD,WRI D:'$D(^TMP($J)) NONE G EXIT
- ;
- CK Q:'$D(^RMPR(661.3,RMLIEN,1,0))
- F J=0:0 S J=$O(^RMPR(661.3,RMLIEN,1,J)) Q:J'>0 F K=0:0 S K=$O(^RMPR(661.3,RMLIEN,1,J,1,K)) Q:K'>0 S RM3=$G(^RMPR(661.3,RMLIEN,1,J,1,K,0)),RMIT=$P(RM3,U,1) D
- .S RMHCPC=$P(RMIT,"-",1),RMDAIT=$P(RMIT,"-",2),RMDAHC=$O(^RMPR(661.1,"B",RMHCPC,0)) Q:'RMDAHC
- .S RM1=$G(^RMPR(661.1,RMDAHC,3,RMDAIT,0)),RMITEM=$P(RM1,U,1) Q:RM1=""
- .S RMBA=$P(RM3,U,2),RMCO=$P(RM3,U,3),RMUNI=$P(RM3,U,4),RMVEN=$P(RM3,U,5)
- .S RMRLE=$P(RM3,U,6),RMDI=$P(RM3,U,7),RMSO=$P(RM3,U,9),RMAV=$P(RM3,U,10)
- .S ^TMP($J,RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN
- Q
- ;write/print report
- WRI S RP="" F S RP=$O(^TMP($J,RP)) Q:RP="" Q:RMPREND K RMPRFLG S J="" F S J=$O(^TMP($J,RP,J)) Q:J="" Q:RMPREND S K="" F S K=$O(^TMP($J,RP,J,K)) Q:K="" Q:RMPREND S RMAST="",RM3=^TMP($J,RP,J,K) D
- .I '$D(RMPRFLG) D HEAD1
- .S RMLODA=$P(RM3,U,9)
- .S RMIT=J
- .S RMITEM=K
- .S RMAV=$P(RM3,U,1)
- .S RMBA=$P(RM3,U,2)
- .S RMCO=$P(RM3,U,3)
- .S RMUNI=$P(RM3,U,4)
- .S RMVEN=$P(RM3,U,5)
- .S RMRLE=$P(RM3,U,6)
- .S RMDI=$P(RM3,U,7)
- .S RMSO=$P(RM3,U,8)
- .S:RMUNI RMUNI=$P($G(^PRCD(420.5,RMUNI,0)),U,1)
- .S:RMVEN RMVEN=$P($G(^PRC(440,RMVEN,0)),U,1)
- .S RMITEM=$E(RMITEM,1,27),RMVEN=$E(RMVEN,1,12)
- .S:RMBA<RMRLE RMAST="*"
- .;I RMSO="V" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?74,$J(RMBA,5)
- .;I RMSO="C" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$J(RMBA,5),RMAST
- .W !,RMIT,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$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 Q
- Q
- ;
- HEAD W !,"*** PROSTHETICS INVENTORY BALANCE BY LOCATION ***",?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 !,"Location: ",RP
- W !,?54,"UNIT",?60,"RE-"
- W !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
- W !,"HCPCS",?9,"ITEM",?36,"SRC",?41,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
- W !,"-----",?9,"----",?36,"---",?41,"------",?53,"-----",?59,"-----",?67,"------",?74,"-----"
- S RMPRFLG=1
- Q
- ;
- ALL ;PROCESS ALL LOCATION
- K RMPRI(0) S RML="" F S RML=$O(^RMPR(661.3,"B",RML)) Q:RML="" D
- .S RLOC=$O(^RMPR(661.3,"B",RML,0))
- .I $P($G(^RMPR(661.3,RLOC,0)),U,3)=RMPR("STA") S RMPRI(RML)=RLOC
- 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[HRMPR5N2 4286 printed Mar 13, 2025@21:38:05 Page 2
- RMPR5N2 ;HIN/RVD-PRINT INVENTORY BALANCE BY LOCATION ;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.3,"
- SET DIC(0)="AEQ"
- SET DIC("S")="I $P(^RMPR(661.3,+Y,0),U,3)=RMPR(""STA"")"
- EN1 READ !!,"Enter 'ALL' for all Locations or 'RETURN' to select individual Locations: ",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
- +3 WRITE !
- FOR RML=1:1
- SET DIC("A")="Select Location "_RML_": "
- DO ^DIC
- if $DATA(DTOUT)!(X["^")!(X=""&(RML=1))
- GOTO EXIT1
- if X=""
- QUIT
- Begin DoDot:1
- +4 SET RMLOCI=$PIECE(^RMPR(661.3,+Y,0),U,1)
- +5 IF $DATA(RMPRI(RMLOCI))
- WRITE $CHAR(7)," ??",?40,"..Duplicate Location"
- SET RML=RML-1
- QUIT
- +6 SET RMPRI(RMLOCI)=+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^RMPR5N2"
- 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 EXIT1
- +3 ;
- PRINT IF $EXTRACT(IOST)["C"
- WRITE !!,"Processing report....."
- +1 SET RMPAGE=1
- SET RMPREND=0
- SET RS=RMPR("STA")
- if $DATA(RMPRI(0))
- DO ALL
- +2 IF '$DATA(RMPRI)
- DO NONE
- GOTO EXIT
- C SET RB=""
- FOR
- SET RB=$ORDER(RMPRI(RB))
- if RB=""
- QUIT
- if RMPREND
- QUIT
- SET RMLIEN=RMPRI(RB)
- DO CK
- +1 if RMPREND
- GOTO EXIT
- +2 if $EXTRACT(IOST)["C"
- WRITE @IOF
- +3 DO HEAD
- DO WRI
- if '$DATA(^TMP($JOB))
- DO NONE
- GOTO EXIT
- +4 ;
- CK if '$DATA(^RMPR(661.3,RMLIEN,1,0))
- QUIT
- +1 FOR J=0:0
- SET J=$ORDER(^RMPR(661.3,RMLIEN,1,J))
- if J'>0
- QUIT
- FOR K=0:0
- SET K=$ORDER(^RMPR(661.3,RMLIEN,1,J,1,K))
- if K'>0
- QUIT
- SET RM3=$GET(^RMPR(661.3,RMLIEN,1,J,1,K,0))
- SET RMIT=$PIECE(RM3,U,1)
- Begin DoDot:1
- +2 SET RMHCPC=$PIECE(RMIT,"-",1)
- SET RMDAIT=$PIECE(RMIT,"-",2)
- SET RMDAHC=$ORDER(^RMPR(661.1,"B",RMHCPC,0))
- if 'RMDAHC
- QUIT
- +3 SET RM1=$GET(^RMPR(661.1,RMDAHC,3,RMDAIT,0))
- SET RMITEM=$PIECE(RM1,U,1)
- if RM1=""
- QUIT
- +4 SET RMBA=$PIECE(RM3,U,2)
- SET RMCO=$PIECE(RM3,U,3)
- SET RMUNI=$PIECE(RM3,U,4)
- SET RMVEN=$PIECE(RM3,U,5)
- +5 SET RMRLE=$PIECE(RM3,U,6)
- SET RMDI=$PIECE(RM3,U,7)
- SET RMSO=$PIECE(RM3,U,9)
- SET RMAV=$PIECE(RM3,U,10)
- +6 SET ^TMP($JOB,RB,RMIT,RMITEM)=RMAV_"^"_RMBA_"^"_RMCO_"^"_RMUNI_"^"_RMVEN_"^"_RMRLE_"^"_RMDI_"^"_RMSO_"^"_RMLIEN
- End DoDot:1
- +7 QUIT
- +8 ;write/print report
- WRI SET RP=""
- FOR
- SET RP=$ORDER(^TMP($JOB,RP))
- if RP=""
- QUIT
- if RMPREND
- QUIT
- KILL RMPRFLG
- SET J=""
- FOR
- SET J=$ORDER(^TMP($JOB,RP,J))
- if J=""
- QUIT
- if RMPREND
- QUIT
- SET K=""
- FOR
- SET K=$ORDER(^TMP($JOB,RP,J,K))
- if K=""
- QUIT
- if RMPREND
- QUIT
- SET RMAST=""
- SET RM3=^TMP($JOB,RP,J,K)
- Begin DoDot:1
- +1 IF '$DATA(RMPRFLG)
- DO HEAD1
- +2 SET RMLODA=$PIECE(RM3,U,9)
- +3 SET RMIT=J
- +4 SET RMITEM=K
- +5 SET RMAV=$PIECE(RM3,U,1)
- +6 SET RMBA=$PIECE(RM3,U,2)
- +7 SET RMCO=$PIECE(RM3,U,3)
- +8 SET RMUNI=$PIECE(RM3,U,4)
- +9 SET RMVEN=$PIECE(RM3,U,5)
- +10 SET RMRLE=$PIECE(RM3,U,6)
- +11 SET RMDI=$PIECE(RM3,U,7)
- +12 SET RMSO=$PIECE(RM3,U,8)
- +13 if RMUNI
- SET RMUNI=$PIECE($GET(^PRCD(420.5,RMUNI,0)),U,1)
- +14 if RMVEN
- SET RMVEN=$PIECE($GET(^PRC(440,RMVEN,0)),U,1)
- +15 SET RMITEM=$EXTRACT(RMITEM,1,27)
- SET RMVEN=$EXTRACT(RMVEN,1,12)
- +16 if RMBA<RMRLE
- SET RMAST="*"
- +17 ;I RMSO="V" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?74,$J(RMBA,5)
- +18 ;I RMSO="C" W !,RMHCPC,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$J(RMRLE,4),?65,$J(RMAV,8,2),?74,$J(RMBA,5),RMAST
- +19 WRITE !,RMIT,?9,RMITEM,?37,RMSO,?41,RMVEN,?55,RMUNI,?58,$JUSTIFY(RMRLE,4),?65,$JUSTIFY(RMAV,8,2),?74,$JUSTIFY(RMBA,5),RMAST
- +20 SET RMPRFLG=1
- +21 IF $EXTRACT(IOST)["C"
- IF ($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
- +22 IF $Y>(IOSL-6)
- WRITE @IOF
- DO HEAD
- DO HEAD1
- QUIT
- End DoDot:1
- +23 QUIT
- +24 ;
- HEAD WRITE !,"*** PROSTHETICS INVENTORY BALANCE BY LOCATION ***",?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"
- IF ($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"
- IF ($Y>(IOSL-6))
- WRITE @IOF
- DO HEAD
- +2 WRITE !,RMPR("L")
- +3 WRITE !,"Location: ",RP
- +4 WRITE !,?54,"UNIT",?60,"RE-"
- +5 WRITE !,?55,"OF",?59,"ORDER",?68,"AVG",?75,"CUR"
- +6 WRITE !,"HCPCS",?9,"ITEM",?36,"SRC",?41,"VENDOR",?53,"ISSUE",?59,"LEVEL",?68,"COST",?75,"BAL"
- +7 WRITE !,"-----",?9,"----",?36,"---",?41,"------",?53,"-----",?59,"-----",?67,"------",?74,"-----"
- +8 SET RMPRFLG=1
- +9 QUIT
- +10 ;
- ALL ;PROCESS ALL LOCATION
- +1 KILL RMPRI(0)
- SET RML=""
- FOR
- SET RML=$ORDER(^RMPR(661.3,"B",RML))
- if RML=""
- QUIT
- Begin DoDot:1
- +2 SET RLOC=$ORDER(^RMPR(661.3,"B",RML,0))
- +3 IF $PIECE($GET(^RMPR(661.3,RLOC,0)),U,3)=RMPR("STA")
- SET RMPRI(RML)=RLOC
- End DoDot:1
- +4 QUIT
- +5 ;
- 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
