- RMPR31U ;PHX/RFM-FUNCTIONS ;8/29/1994
- ;;3.0;PROSTHETICS;;Feb 09, 1996
- ITM(X) ; Displays external name of an item
- ; X=Internal number from 661
- S X=+X
- I '$D(^RMPR(661,X,0)) Q "Item not Found"
- S X=$P(^PRC(441,$P(^RMPR(661,X,0),U),0),U,2)
- Q X
- ITM1(X) ; Display # of an item
- ; X=Internal number from 661
- S X=+X
- I '$D(^RMPR(661,X,0)) Q "Item not Found"
- S X=$P(^PRC(441,$P(^RMPR(661,X,0),U),0),U,1)
- Q X
- ;
- VEN(X) ; Displays external name of a vendor
- ; X=Internal number of vendor from 440
- S X=+X
- I '$D(^PRC(440,X,0)) Q "Vendor not found"
- S X=$P(^PRC(440,X,0),U)
- Q X
- ;
- PAT(X) ; Displays name of Patient
- N RX
- S RX=X,X=$$NAMESSN^RMPRU(RX)
- Q $P(X,U,1)
- ; X=Patient IEN
- ;S X=+X
- ;II'$D(^DPT(X,0)) Q "Patient not found"
- ;S X=$P(^DPT(X,0),U)
- ;Q X
- ;
- EMP(X) ; Displays name of employee
- ; X=Internal number from 200
- S X=+X
- S X=$S($D(^VA(200,X,0)):$P(^(0),U),1:"")
- Q X
- ;
- ITEM(X) ; Displays name of item from 660
- ; X=IEN of record from 660
- S X=+X
- I '$D(^RMPR(660,X,0)) Q ""
- I '$D(^RMPR(661,+$P(^RMPR(660,X,0),U,6),0)) Q ""
- S X=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,X,0),U,6),0),U),0),U,2)
- Q X
- ITMN(X) ; Displays NUMBER of item from 660
- ; X=IEN of record from 660
- S X=+X
- I '$D(^RMPR(660,X,0)) Q ""
- I '$D(^RMPR(661,+$P(^RMPR(660,X,0),U,6),0)) Q ""
- S X=$P(^PRC(441,$P(^RMPR(661,$P(^RMPR(660,X,0),U,6),0),U),0),U,1)
- Q X
- SIG(X) ;Displays Printed signature bock from file 200
- S X=+X
- S X=$S($D(^VA(200,X,20)):$P(^(20),U,2),1:"")
- Q X
- STA(X) ;Displays Station Name from file Institution File
- S X=+X
- S X=$S($D(^DIC(4,X,0)):$P(^(0),U),1:"")
- Q X
- STAN(X) ;Displays Station Number from file Institution File
- S X=+X
- S X=$S($D(^DIC(4,X,99)):$P(^(99),U),1:"")
- Q X
- CODE(PZD,TYPE,SRC) ;GET ORTHOTIC OR RESTORATION CODE
- ;N RAM
- I TYPE="X",SRC="R" S AMIS=$S(+$P(RMPRAM,U,2):"134",1:$P($G(^RMPR(663,+$P(PZD,U,8),0)),U,5))_U_$S($D(RMPRGEC):$P($G(^RMPR(663,+$P(PZD,U,8),0)),U),1:+$P(PZD,U,8))
- I TYPE="X",SRC'="R" S AMIS=$S(+$P(RMPRAM,U,2):"138",1:$P($G(^RMPR(663,+$P(PZD,U,6),0)),U,5))_U_$S($D(RMPRGEC):$P($G(^RMPR(663,+$P(PZD,U,6),0)),U),1:+$P(PZD,U,6))
- I TYPE'="X",SRC'="R" S AMIS=$S(+$P(RMPRAM,U,2):"138",1:$P($G(^RMPR(663,+$P(PZD,U,5),0)),U,5))_U_$S($D(RMPRGEC):$P($G(^RMPR(663,+$P(PZD,U,5),0)),U),1:+$P(PZD,U,5))
- I TYPE'="X",SRC="R" S AMIS=$S(+$P(RMPRAM,U,2):"134",1:$P($G(^RMPR(663,+$P(PZD,U,7),0)),U,5))_U_$S($D(RMPRGEC):$P($G(^RMPR(663,+$P(PZD,U,7),0)),U),1:+$P(PZD,U,7))
- I '$D(RMPRGEC),$G(RMPRE),RMPRE'=$P(AMIS,U,2) S AMIS=""
- Q AMIS
- BLD ;BUILD TMP GLOBAL FOR LAB/RESTORATION AMIS
- N RI,RA,RT
- F RI=132,133,135,136,137 F RT=0:0 S RT=$O(^RMPR(663,"E",RI,RT)) Q:RT'>0 I $D(^RMPR(663,RT,0)) S ^TMP($J,RI_U_$P(^RMPR(663,RT,0),U))="0^0^0^0^0^0^0^0^0"
- F RA=134,138 F RI="01","02","03","04","05","06","07","08","09","10" S ^TMP($J,RA_U_RI)="0^0^0^0^0^0^0"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR31U 2866 printed Jan 18, 2025@03:33:43 Page 2
- RMPR31U ;PHX/RFM-FUNCTIONS ;8/29/1994
- +1 ;;3.0;PROSTHETICS;;Feb 09, 1996
- ITM(X) ; Displays external name of an item
- +1 ; X=Internal number from 661
- +2 SET X=+X
- +3 IF '$DATA(^RMPR(661,X,0))
- QUIT "Item not Found"
- +4 SET X=$PIECE(^PRC(441,$PIECE(^RMPR(661,X,0),U),0),U,2)
- +5 QUIT X
- ITM1(X) ; Display # of an item
- +1 ; X=Internal number from 661
- +2 SET X=+X
- +3 IF '$DATA(^RMPR(661,X,0))
- QUIT "Item not Found"
- +4 SET X=$PIECE(^PRC(441,$PIECE(^RMPR(661,X,0),U),0),U,1)
- +5 QUIT X
- +6 ;
- VEN(X) ; Displays external name of a vendor
- +1 ; X=Internal number of vendor from 440
- +2 SET X=+X
- +3 IF '$DATA(^PRC(440,X,0))
- QUIT "Vendor not found"
- +4 SET X=$PIECE(^PRC(440,X,0),U)
- +5 QUIT X
- +6 ;
- PAT(X) ; Displays name of Patient
- +1 NEW RX
- +2 SET RX=X
- SET X=$$NAMESSN^RMPRU(RX)
- +3 QUIT $PIECE(X,U,1)
- +4 ; X=Patient IEN
- +5 ;S X=+X
- +6 ;II'$D(^DPT(X,0)) Q "Patient not found"
- +7 ;S X=$P(^DPT(X,0),U)
- +8 ;Q X
- +9 ;
- EMP(X) ; Displays name of employee
- +1 ; X=Internal number from 200
- +2 SET X=+X
- +3 SET X=$SELECT($DATA(^VA(200,X,0)):$PIECE(^(0),U),1:"")
- +4 QUIT X
- +5 ;
- ITEM(X) ; Displays name of item from 660
- +1 ; X=IEN of record from 660
- +2 SET X=+X
- +3 IF '$DATA(^RMPR(660,X,0))
- QUIT ""
- +4 IF '$DATA(^RMPR(661,+$PIECE(^RMPR(660,X,0),U,6),0))
- QUIT ""
- +5 SET X=$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,X,0),U,6),0),U),0),U,2)
- +6 QUIT X
- ITMN(X) ; Displays NUMBER of item from 660
- +1 ; X=IEN of record from 660
- +2 SET X=+X
- +3 IF '$DATA(^RMPR(660,X,0))
- QUIT ""
- +4 IF '$DATA(^RMPR(661,+$PIECE(^RMPR(660,X,0),U,6),0))
- QUIT ""
- +5 SET X=$PIECE(^PRC(441,$PIECE(^RMPR(661,$PIECE(^RMPR(660,X,0),U,6),0),U),0),U,1)
- +6 QUIT X
- SIG(X) ;Displays Printed signature bock from file 200
- +1 SET X=+X
- +2 SET X=$SELECT($DATA(^VA(200,X,20)):$PIECE(^(20),U,2),1:"")
- +3 QUIT X
- STA(X) ;Displays Station Name from file Institution File
- +1 SET X=+X
- +2 SET X=$SELECT($DATA(^DIC(4,X,0)):$PIECE(^(0),U),1:"")
- +3 QUIT X
- STAN(X) ;Displays Station Number from file Institution File
- +1 SET X=+X
- +2 SET X=$SELECT($DATA(^DIC(4,X,99)):$PIECE(^(99),U),1:"")
- +3 QUIT X
- CODE(PZD,TYPE,SRC) ;GET ORTHOTIC OR RESTORATION CODE
- +1 ;N RAM
- +2 IF TYPE="X"
- IF SRC="R"
- SET AMIS=$SELECT(+$PIECE(RMPRAM,U,2):"134",1:$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,8),0)),U,5))_U_$SELECT($DATA(RMPRGEC):$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,8),0)),U),1:+$PIECE(PZD,U,8))
- +3 IF TYPE="X"
- IF SRC'="R"
- SET AMIS=$SELECT(+$PIECE(RMPRAM,U,2):"138",1:$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,6),0)),U,5))_U_$SELECT($DATA(RMPRGEC):$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,6),0)),U),1:+$PIECE(PZD,U,6))
- +4 IF TYPE'="X"
- IF SRC'="R"
- SET AMIS=$SELECT(+$PIECE(RMPRAM,U,2):"138",1:$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,5),0)),U,5))_U_$SELECT($DATA(RMPRGEC):$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,5),0)),U),1:+$PIECE(PZD,U,5))
- +5 IF TYPE'="X"
- IF SRC="R"
- SET AMIS=$SELECT(+$PIECE(RMPRAM,U,2):"134",1:$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,7),0)),U,5))_U_$SELECT($DATA(RMPRGEC):$PIECE($GET(^RMPR(663,+$PIECE(PZD,U,7),0)),U),1:+$PIECE(PZD,U,7))
- +6 IF '$DATA(RMPRGEC)
- IF $GET(RMPRE)
- IF RMPRE'=$PIECE(AMIS,U,2)
- SET AMIS=""
- +7 QUIT AMIS
- BLD ;BUILD TMP GLOBAL FOR LAB/RESTORATION AMIS
- +1 NEW RI,RA,RT
- +2 FOR RI=132,133,135,136,137
- FOR RT=0:0
- SET RT=$ORDER(^RMPR(663,"E",RI,RT))
- if RT'>0
- QUIT
- IF $DATA(^RMPR(663,RT,0))
- SET ^TMP($JOB,RI_U_$PIECE(^RMPR(663,RT,0),U))="0^0^0^0^0^0^0^0^0"
- +3 FOR RA=134,138
- FOR RI="01","02","03","04","05","06","07","08","09","10"
- SET ^TMP($JOB,RA_U_RI)="0^0^0^0^0^0^0"
- +4 QUIT