- RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
- ;;3.0;PROSTHETICS;;Feb 09, 1996
- EN ;entry to Prosthetic Service Card from purchasing
- W !!?7,"NAME",?50,"SERIAL NUMBER",!
- S RMPRX=0 F I=0:0 S I=$O(^RMPR(665,RMPRDFN,5,I)) Q:I'>0 D PRT
- R !!,"SELECT NUMBER: ",RMPRPC:DTIME I '$T!(RMPRPC["^") S RMPRFLG=1 Q
- I '$D(^RMPR(665,RMPRDFN,5,+RMPRPC,0)) W !?5,$C(7),$C(7),"To obligate funds on this transaction, the veteran must",!?5,"have a PSC issued for that item." G EN
- S RMPRPI=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4) I RMPRPI="" W !,$C(7) G EN
- S RMPRSR(RMPRPI)=$P(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
- S RMPRPI=$P(^RMPR(661,RMPRPI,0),U,1)
- ;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
- K RMPRX,RMPRIN,RMPRI,RMPRPC Q
- ;
- PRT ;print items
- S RMPRX=^RMPR(665,RMPRDFN,5,I,0),RMPRI=$P(RMPRX,U,4) I RMPRI'="" S RMPRIN=$P(^RMPR(661,RMPRI,0),U,1),RMPRIN=$E($P(^PRC(441,RMPRIN,0),U,2),1,30)
- I RMPRI'="" W !,I_".",?7,$S($P(RMPRX,U,2)?1A.E:$P(RMPRX,U,2),1:RMPRIN),?50,$P(RMPRX,U,3)
- Q
- PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
- S DIC="^RMPR(665,",DIC(0)="AEQMZ" D ^DIC G:+Y'>0 EXIT S RMPRDFN=+Y
- DT ;ENTER EDIT PSC CARD
- I '$D(^RMPR(665,RMPRDFN,5)) S ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
- S DIC="^RMPR(665,"_RMPRDFN_",5,",DIC(0)="AEQMZL",DLAYGO=665
- S DIC("W")="W "" "",$S($P(^(0),U,2)]"""":$E($P(^(0),U,2),1,30),$D(^RMPR(661,+$P(^(0),U,4),0)):$E($P(^PRC(441,$P(^(0),U,1),0),U,2),1,30),1:"""")_"" ""_$P(^RMPR(665,RMPRDFN,5,Y,0),U,3)"
- D ^DIC K DLAYGO I +Y'>0 K DIC,DIE,DA,Y G:$D(RFL) EXIT G PSC
- L +^RMPR(665,RMPRDFN,5,+Y):1 I $T=0 W !,?5,$C(7),"Someone is Editing this entry!" G EXIT
- S DIE=DIC,NEW=+$P(Y,U,3),DA(1)=RMPRDFN,(DA,RDA)=+Y S DR=$S(NEW:".01:1",'NEW:".01:3") D ^DIE L -^RMPR(665,RMPRDFN,5,RDA)
- I '$D(^RMPR(665,RMPRDFN,5,RDA,0)) G DT
- I $D(^RMPR(665,DA(1),5,DA,0))&'$P(^(0),U,4) S DIK="^RMPR(665,"_RMPRDFN_",5,",DA(1)=RMPRDFN D ^DIK W !,?5,$C(7),"Deleted..." K DIE,DIC,DA G DT
- G:'NEW DT S DR="2:3" D ^DIE G DT
- EXIT ;common exit point
- Q:$D(RMPRFLAG) K DIC,DIE,R90,RDA,DR,NEW Q
- EYE ;EDIT FOR EYE GLASSES
- ;
- S VENDOR=$$VEN^RMPR31U($P($G(^RMPR(660.5,+$G(RMPRDA),0)),U,4))
- I VENDOR="Vendor not found" S VENDOR=""
- S DR="4//^S X=VENDOR" D ^DIE K VENDOR
- I $D(DTOUT)!($D(Y)'=0) G KILL^RMPR21
- ;
- AA S X=$P($G(^RMPR(669.9,RMPRSITE,3)),U,3) I X'="" S DIC("B")=$$ITM^RMPR31U(X)
- K DIC,Y S DIC=661,DIC(0)="AEQMZ",DIC("A")="ITEM (for AMIS): ",DIC("S")="S Z=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+Z>0 I $P(^RMPR(663,+Z,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
- K DIC,Y S DIC=661,DIC(0)="MZ",X="EYEGLASSES",DIC("S")="S R90=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+R90>0 I $P(^RMPR(663,+R90,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")" D ^DIC I +Y'>0 G KILL^RMPR21
- K DIC,DIE S RMPRPI=$P(Y,U,2) S DIE="^RMPR(664,",DR="[RMPREYE]"
- D ^DIE G CHK^RMPR21
- PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
- D EN3^PRCSUT I Y=-1 Q
- K PRCS W !,"Select OBLIGATION NUMBER: ",RMPROB,"// " R X:DTIME S:'$T X="^" W:X["?" !!,?5,"Please Enter '^' to Exit" Q:X["^" S X=$S(X="":RMPROB,1:X) S DIC("S")="S RX=^(0) I +RX=+PRC(""SITE""),+$P(RX,U,3)=+PRC(""CP""),+$P(RX,U,2)=21"
- S DIC=442,DIC(0)="MQXZ" D ^DIC G:+Y'>0 PRCS S RMPROB=$P(Y,U,2)
- BAL ;check IFCAP version
- S RDA=$O(^DIC(9.4,"C","PRC",0)) I $D(^DIC(9.4,+RDA,"VERSION")) S RVA=+^("VERSION")
- I +RVA<4 W !,"1358 Balance is $",$FN($P(^PRC(442,$P(Y,U),8),U,3),"P",2) Q
- I +RVA'<4 S RBL=$P(^PRC(442,$P(Y,U),8),U)-$P(^(8),U,3) W !,"1358 Balance is $",$FN(RBL,"P",2) Q
- K RDA,RVA,RBL Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPRPSC 3515 printed Feb 19, 2025@00:03:58 Page 2
- RMPRPSC ;PHX/HNB-PRINT PSC LISTING ;8/29/1994
- +1 ;;3.0;PROSTHETICS;;Feb 09, 1996
- EN ;entry to Prosthetic Service Card from purchasing
- +1 WRITE !!?7,"NAME",?50,"SERIAL NUMBER",!
- +2 SET RMPRX=0
- FOR I=0:0
- SET I=$ORDER(^RMPR(665,RMPRDFN,5,I))
- if I'>0
- QUIT
- DO PRT
- +3 READ !!,"SELECT NUMBER: ",RMPRPC:DTIME
- IF '$TEST!(RMPRPC["^")
- SET RMPRFLG=1
- QUIT
- +4 IF '$DATA(^RMPR(665,RMPRDFN,5,+RMPRPC,0))
- WRITE !?5,$CHAR(7),$CHAR(7),"To obligate funds on this transaction, the veteran must",!?5,"have a PSC issued for that item."
- GOTO EN
- +5 SET RMPRPI=$PIECE(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,4)
- IF RMPRPI=""
- WRITE !,$CHAR(7)
- GOTO EN
- +6 SET RMPRSR(RMPRPI)=$PIECE(^RMPR(665,RMPRDFN,5,+RMPRPC,0),U,3)
- +7 SET RMPRPI=$PIECE(^RMPR(661,RMPRPI,0),U,1)
- +8 ;MUST PASS RMPRSR,RMPRPI TO RMPR21 TO POST SERIAL NUMBERS
- +9 KILL RMPRX,RMPRIN,RMPRI,RMPRPC
- QUIT
- +10 ;
- PRT ;print items
- +1 SET RMPRX=^RMPR(665,RMPRDFN,5,I,0)
- SET RMPRI=$PIECE(RMPRX,U,4)
- IF RMPRI'=""
- SET RMPRIN=$PIECE(^RMPR(661,RMPRI,0),U,1)
- SET RMPRIN=$EXTRACT($PIECE(^PRC(441,RMPRIN,0),U,2),1,30)
- +2 IF RMPRI'=""
- WRITE !,I_".",?7,$SELECT($PIECE(RMPRX,U,2)?1A.E:$PIECE(RMPRX,U,2),1:RMPRIN),?50,$PIECE(RMPRX,U,3)
- +3 QUIT
- PSC ;ENTRY POINT FOR CREATING PSC ITEMS FOR A PATIENT
- +1 SET DIC="^RMPR(665,"
- SET DIC(0)="AEQMZ"
- DO ^DIC
- if +Y'>0
- GOTO EXIT
- SET RMPRDFN=+Y
- DT ;ENTER EDIT PSC CARD
- +1 IF '$DATA(^RMPR(665,RMPRDFN,5))
- SET ^RMPR(665,RMPRDFN,5,0)="^665.012ID^0^0"
- +2 SET DIC="^RMPR(665,"_RMPRDFN_",5,"
- SET DIC(0)="AEQMZL"
- SET DLAYGO=665
- +3 SET DIC("W")="W "" "",$S($P(^(0),U,2)]"""":$E($P(^(0),U,2),1,30),$D(^RMPR(661,+$P(^(0),U,4),0)):$E($P(^PRC(441,$P(^(0),U,1),0),U,2),1,30),1:"""")_"" ""_$P(^RMPR(665,RMPRDFN,5,Y,0),U,3)"
- +4 DO ^DIC
- KILL DLAYGO
- IF +Y'>0
- KILL DIC,DIE,DA,Y
- if $DATA(RFL)
- GOTO EXIT
- GOTO PSC
- +5 LOCK +^RMPR(665,RMPRDFN,5,+Y):1
- IF $TEST=0
- WRITE !,?5,$CHAR(7),"Someone is Editing this entry!"
- GOTO EXIT
- +6 SET DIE=DIC
- SET NEW=+$PIECE(Y,U,3)
- SET DA(1)=RMPRDFN
- SET (DA,RDA)=+Y
- SET DR=$SELECT(NEW:".01:1",'NEW:".01:3")
- DO ^DIE
- LOCK -^RMPR(665,RMPRDFN,5,RDA)
- +7 IF '$DATA(^RMPR(665,RMPRDFN,5,RDA,0))
- GOTO DT
- +8 IF $DATA(^RMPR(665,DA(1),5,DA,0))&'$PIECE(^(0),U,4)
- SET DIK="^RMPR(665,"_RMPRDFN_",5,"
- SET DA(1)=RMPRDFN
- DO ^DIK
- WRITE !,?5,$CHAR(7),"Deleted..."
- KILL DIE,DIC,DA
- GOTO DT
- +9 if 'NEW
- GOTO DT
- SET DR="2:3"
- DO ^DIE
- GOTO DT
- EXIT ;common exit point
- +1 if $DATA(RMPRFLAG)
- QUIT
- KILL DIC,DIE,R90,RDA,DR,NEW
- QUIT
- EYE ;EDIT FOR EYE GLASSES
- +1 ;
- +2 SET VENDOR=$$VEN^RMPR31U($PIECE($GET(^RMPR(660.5,+$GET(RMPRDA),0)),U,4))
- +3 IF VENDOR="Vendor not found"
- SET VENDOR=""
- +4 SET DR="4//^S X=VENDOR"
- DO ^DIE
- KILL VENDOR
- +5 IF $DATA(DTOUT)!($DATA(Y)'=0)
- GOTO KILL^RMPR21
- +6 ;
- AA SET X=$PIECE($GET(^RMPR(669.9,RMPRSITE,3)),U,3)
- IF X'=""
- SET DIC("B")=$$ITM^RMPR31U(X)
- +1 KILL DIC,Y
- SET DIC=661
- SET DIC(0)="AEQMZ"
- SET DIC("A")="ITEM (for AMIS): "
- SET DIC("S")="S Z=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+Z>0 I $P(^RMPR(663,+Z,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")"
- DO ^DIC
- IF +Y'>0
- GOTO KILL^RMPR21
- +2 KILL DIC,Y
- SET DIC=661
- SET DIC(0)="MZ"
- SET X="EYEGLASSES"
- SET DIC("S")="S R90=$P(^(0),U,3),R1=$P(^(0),U,4) I +R1>0,+R90>0 I $P(^RMPR(663,+R90,0),U,1)=11!($P(^RMPR(663,+R1,0),U,1)=""R06"")"
- DO ^DIC
- IF +Y'>0
- GOTO KILL^RMPR21
- +3 KILL DIC,DIE
- SET RMPRPI=$PIECE(Y,U,2)
- SET DIE="^RMPR(664,"
- SET DR="[RMPREYE]"
- +4 DO ^DIE
- GOTO CHK^RMPR21
- PRCS ;ENTRY POINT FOR DISPLAYING 1358 BALANCE
- +1 DO EN3^PRCSUT
- IF Y=-1
- QUIT
- +2 KILL PRCS
- WRITE !,"Select OBLIGATION NUMBER: ",RMPROB,"// "
- READ X:DTIME
- if '$TEST
- SET X="^"
- if X["?"
- WRITE !!,?5,"Please Enter '^' to Exit"
- if X["^"
- QUIT
- SET X=$SELECT(X="":RMPROB,1:X)
- SET DIC("S")="S RX=^(0) I +RX=+PRC(""SITE""),+$P(RX,U,3)=+PRC(""CP""),+$P(RX,U,2)=21"
- +3 SET DIC=442
- SET DIC(0)="MQXZ"
- DO ^DIC
- if +Y'>0
- GOTO PRCS
- SET RMPROB=$PIECE(Y,U,2)
- BAL ;check IFCAP version
- +1 SET RDA=$ORDER(^DIC(9.4,"C","PRC",0))
- IF $DATA(^DIC(9.4,+RDA,"VERSION"))
- SET RVA=+^("VERSION")
- +2 IF +RVA<4
- WRITE !,"1358 Balance is $",$FNUMBER($PIECE(^PRC(442,$PIECE(Y,U),8),U,3),"P",2)
- QUIT
- +3 IF +RVA'<4
- SET RBL=$PIECE(^PRC(442,$PIECE(Y,U),8),U)-$PIECE(^(8),U,3)
- WRITE !,"1358 Balance is $",$FNUMBER(RBL,"P",2)
- QUIT
- +4 KILL RDA,RVA,RBL
- QUIT