RMPR29I ;PHX/JLT-PRINT PENDING/CLOSED/ASSIGNED [ 10/18/94 1:34 PM ]
;;3.0;PROSTHETICS;;Feb 09, 1996
PC ;REPORT 2529-3 PENDING COMPLETION
K QUIT D ST^RMPRDT G:$D(QUIT) EXIT
S DIC="^RMPR(664.1,",BY="@.01",FR=DATE(1),TO=DATE(2)
;Screen DIS(0)
;if not DATE DELIVERED
;if STATION equal to division selected
;if RECEIVING STATION not equal to division selected
;if STATUS is PC
S DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)'=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""PC""" D FLDS Q
PEN ;PENDING 2529-3s
;if not DATE DELIVERED
;if STATION equal to division selected
;if STATUS is P
K QUIT D ST^RMPRDT G:$D(QUIT) EXIT
S DIC="^RMPR(664.1,",BY="@.01",FR=DATE(1),TO=DATE(2)
;screen DIS(0)
S DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""P"""
FLDS ;set flds array for call to dip
S FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
S FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",.01;C40;""DATE INIT"",TODAY-DATE;C60;""#DAYS"",""WORK FOR: "";C1,2;C11;X,D DIS^RMPR29I;X;C40",FLDS(2)="6,""ITEM:"";C1;X,.01;C10;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
S L=0,DHD=" <PENDING 2529-3s>",DHIT="D LINE^RMPR29I" D EN1^DIP
EXIT ;common exit point
K BY,D0,D1,DATE,DHD,DHIT,DIC,DIS,FLDS,FR,LDAT,LP,PZD,QUIT,RA,RAT,RD0,RD1,RLAB,RRA,RVAR,RRRZ,SRC,TO,TYPE,X,Y,L
Q
DIS ;DISLAY DISABILITY
N RR,RD
I $D(^RMPR(664.1,D0,1)) D
.W "DIS CODE: "
.S RR=0,RD=""
.F S RR=$O(^RMPR(664.1,D0,1,RR)) Q:RR'>0 D
..S RD=$P(^RMPR(664.1,D0,1,RR,0),U,1)
..Q:RD=""
..W $P(^RMPR(662,RD,0),U)_"-"_$S($P(^RMPR(664.1,D0,1,RR,0),U,2)=1:"SC",1:"NSC") I $O(^RMPR(664.1,D0,1,RR)) W ","
;see internal notes, fix on a FM problem.
S X=""
Q
ADC ;GET AMIS CODE
D ADC^RMPR293(D0,D1) S X="" Q
LINE ;WRITE A DASHED LINE
I $Y>5 K LP S $P(LP,"-",IOM)="" W LP
Q
ASN ;ASSIGNED 2529-3s
K QUIT D ST^RMPRDT G:$D(QUIT) EXIT
S DIC="^RMPR(664.1,",BY="@.01",FR=DATE(1),TO=DATE(2),DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""A"""
S FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
S FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE ASSIGNED-DATE;C60;""#DAYS PENDING"";W15"
S FLDS(2)="""ASSIGNED BY:"";C1,ASSIGNED BY;C15;X,""DATE ASSIGNED"";C40,DATE ASSIGNED;X;C60"
S FLDS(3)="""WORK FOR: "";C1,2;C11;X,""ASSIGNED TO:"";C40,STRIPBLANKS(TECHNICIAN);C60;X"
S FLDS(4)="D DIS^RMPR29I;C1;X"
S FLDS(5)="6,""ITEM:"";C1;X,.01;C10;X,D LEW^RMPR29I;C40;X,D STN^RMPR29I;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
S FLDS(6)="6,""LABOR COST:"";X;C1,5:STRIPBLANKS(TOTAL LABOR COST);X;C15,""MATERIAL COST:"";X;C24,5:STRIPBLANKS(TOTAL MATERIAL COST);X;C40,""TOTAL COST:"";X;C50,5:STRIPBLANKS(TOTAL LAB COST);X;C65"
S DHD=" <ASSIGNED/OPEN 2529-3s>",DHIT="D LINE^RMPR29I" D EN1^DIP
D EXIT Q
LEW ;GET LAST WORK DATE ENTRY
N Y
K RVAR S LDAT(2)=0,RAT=$P($G(^RMPR(664.1,D0,2,D1,0)),U,5)
I +RAT F RA=0:0 S RA=$O(^RMPR(664.3,"C",RAT,RA)) Q:RA'>0 S RVAR=RA D
.I $D(RVAR) S LDAT(1)=$P($G(^RMPR(664.3,RVAR,0)),U) I LDAT(1)>LDAT(2) S LDAT(2)=LDAT(1)
I LDAT(2)=0 W "LAST WORK DATE: " Q
S Y=LDAT(2) D DD^%DT W "LAST WORK DATE: "_Y
S X=""
Q
STN ;GET STATUS OF PROCUREMENT
S RAT=$P($G(^RMPR(664.1,D0,2,D1,0)),U,6) I +RAT F RA=0:0 S RA=$O(^RMPR(664.2,+RAT,1,RA)) Q:RA'>0 S RRA=(^(RA,0)) D
.I $D(^RMPR(664,+$P(RRA,U,11),0)),'$P(^(0),U,8) W !,?9,"2421 PURCHASE "_$P(RRA,U,10)_" PENDING DELIVERY"
.I $D(^RMPR(664.1,+$P(RRA,U,13),0)),'$P(^(0),U,26) W !,?9,"2529-3 REQUEST "_$P(RRA,U,10)_" PENDING DELIVERY"
S X=""
Q
OCLS ;DISPLAY CLOSED REMOTE 2529-3
K QUIT D ST^RMPRDT G:$D(QUIT) EXIT
S DIC="^RMPR(664.1,",BY="@20",FR=DATE(1),TO=DATE(2),DIS(0)="I $P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)'=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""C""" D FLDSC Q
CLS ;CLOSED 2529-3s
K QUIT D ST^RMPRDT G:$D(QUIT) EXIT
S L=0
S DIC="^RMPR(664.1,",BY="@20",FR=DATE(1),TO=DATE(2),DIS(0)="I $P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""C"""
S FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
S FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE DELIVERED-DATE;C60;""#DAYS OPEN"";W15"
S FLDS(2)="""ASSIGNED BY:"";C1,ASSIGNED BY;C15;X,""DATE ASSIGNED"";C40,DATE ASSIGNED;X;C60"
S FLDS(3)="""WORK FOR: "";C1,2;C11;X,""ASSIGNED TO:"";C40,STRIPBLANKS(TECHNICIAN);C60;X"
S FLDS(4)="D DIS^RMPR29I;C1;X"
S FLDS(5)="6,""ITEM:"";C1;X,.01;C10;X,D LEW^RMPR29I;C40;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
S FLDS(6)="6,""LABOR COST:"";X;C1,5:STRIPBLANKS(TOTAL LABOR COST);X;C15,""MATERIAL COST:"";X;C24,5:STRIPBLANKS(TOTAL MATERIAL COST);X;C40,""TOTAL COST:"";X;C50,5:STRIPBLANKS(TOTAL LAB COST);X;C65"
S FLDS(7)="""DELIVERY DATE"";C1;X,20;C15;X"
S DHD=" <CLOSED 2529-3s>",DHIT="D LINE^RMPR29I" D EN1^DIP
D EXIT Q
FLDSC ;set flds array for call to dip
S FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
S FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE DELIVERED-DATE;C60;""#DAYS OPEN"";W15"
S FLDS(2)="""WORK FOR: "";C1,2;C11;X,D DIS^RMPR29I;C40;X"
S FLDS(3)="6,""ITEM:"";C1;X,.01;C10,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X",FLDS(4)="""DELIVERY DATE"";C1;X,20;C15;X"
S DHD=" <CLOSED 2529-3s>",DHIT="D LINE^RMPR29I" D EN1^DIP
D EXIT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRMPR29I 5698 printed Dec 13, 2024@02:32:11 Page 2
RMPR29I ;PHX/JLT-PRINT PENDING/CLOSED/ASSIGNED [ 10/18/94 1:34 PM ]
+1 ;;3.0;PROSTHETICS;;Feb 09, 1996
PC ;REPORT 2529-3 PENDING COMPLETION
+1 KILL QUIT
DO ST^RMPRDT
if $DATA(QUIT)
GOTO EXIT
+2 SET DIC="^RMPR(664.1,"
SET BY="@.01"
SET FR=DATE(1)
SET TO=DATE(2)
+3 ;Screen DIS(0)
+4 ;if not DATE DELIVERED
+5 ;if STATION equal to division selected
+6 ;if RECEIVING STATION not equal to division selected
+7 ;if STATUS is PC
+8 SET DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)'=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""PC"""
DO FLDS
QUIT
PEN ;PENDING 2529-3s
+1 ;if not DATE DELIVERED
+2 ;if STATION equal to division selected
+3 ;if STATUS is P
+4 KILL QUIT
DO ST^RMPRDT
if $DATA(QUIT)
GOTO EXIT
+5 SET DIC="^RMPR(664.1,"
SET BY="@.01"
SET FR=DATE(1)
SET TO=DATE(2)
+6 ;screen DIS(0)
+7 SET DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""P"""
FLDS ;set flds array for call to dip
+1 SET FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
+2 SET FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",.01;C40;""DATE INIT"",TODAY-DATE;C60;""#DAYS"",""WORK FOR: "";C1,2;C11;X,D DIS^RMPR29I;X;C40"
SET FLDS(2)="6,""ITEM:"";C1;X,.01;C10;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
+3 SET L=0
SET DHD=" <PENDING 2529-3s>"
SET DHIT="D LINE^RMPR29I"
DO EN1^DIP
EXIT ;common exit point
+1 KILL BY,D0,D1,DATE,DHD,DHIT,DIC,DIS,FLDS,FR,LDAT,LP,PZD,QUIT,RA,RAT,RD0,RD1,RLAB,RRA,RVAR,RRRZ,SRC,TO,TYPE,X,Y,L
+2 QUIT
DIS ;DISLAY DISABILITY
+1 NEW RR,RD
+2 IF $DATA(^RMPR(664.1,D0,1))
Begin DoDot:1
+3 WRITE "DIS CODE: "
+4 SET RR=0
SET RD=""
+5 FOR
SET RR=$ORDER(^RMPR(664.1,D0,1,RR))
if RR'>0
QUIT
Begin DoDot:2
+6 SET RD=$PIECE(^RMPR(664.1,D0,1,RR,0),U,1)
+7 if RD=""
QUIT
+8 WRITE $PIECE(^RMPR(662,RD,0),U)_"-"_$SELECT($PIECE(^RMPR(664.1,D0,1,RR,0),U,2)=1:"SC",1:"NSC")
IF $ORDER(^RMPR(664.1,D0,1,RR))
WRITE ","
End DoDot:2
End DoDot:1
+9 ;see internal notes, fix on a FM problem.
+10 SET X=""
+11 QUIT
ADC ;GET AMIS CODE
+1 DO ADC^RMPR293(D0,D1)
SET X=""
QUIT
LINE ;WRITE A DASHED LINE
+1 IF $Y>5
KILL LP
SET $PIECE(LP,"-",IOM)=""
WRITE LP
+2 QUIT
ASN ;ASSIGNED 2529-3s
+1 KILL QUIT
DO ST^RMPRDT
if $DATA(QUIT)
GOTO EXIT
+2 SET DIC="^RMPR(664.1,"
SET BY="@.01"
SET FR=DATE(1)
SET TO=DATE(2)
SET DIS(0)="I '$P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""A"""
+3 SET FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
+4 SET FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE ASSIGNED-DATE;C60;""#DAYS PENDING"";W15"
+5 SET FLDS(2)="""ASSIGNED BY:"";C1,ASSIGNED BY;C15;X,""DATE ASSIGNED"";C40,DATE ASSIGNED;X;C60"
+6 SET FLDS(3)="""WORK FOR: "";C1,2;C11;X,""ASSIGNED TO:"";C40,STRIPBLANKS(TECHNICIAN);C60;X"
+7 SET FLDS(4)="D DIS^RMPR29I;C1;X"
+8 SET FLDS(5)="6,""ITEM:"";C1;X,.01;C10;X,D LEW^RMPR29I;C40;X,D STN^RMPR29I;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
+9 SET FLDS(6)="6,""LABOR COST:"";X;C1,5:STRIPBLANKS(TOTAL LABOR COST);X;C15,""MATERIAL COST:"";X;C24,5:STRIPBLANKS(TOTAL MATERIAL COST);X;C40,""TOTAL COST:"";X;C50,5:STRIPBLANKS(TOTAL LAB COST);X;C65"
+10 SET DHD=" <ASSIGNED/OPEN 2529-3s>"
SET DHIT="D LINE^RMPR29I"
DO EN1^DIP
+11 DO EXIT
QUIT
LEW ;GET LAST WORK DATE ENTRY
+1 NEW Y
+2 KILL RVAR
SET LDAT(2)=0
SET RAT=$PIECE($GET(^RMPR(664.1,D0,2,D1,0)),U,5)
+3 IF +RAT
FOR RA=0:0
SET RA=$ORDER(^RMPR(664.3,"C",RAT,RA))
if RA'>0
QUIT
SET RVAR=RA
Begin DoDot:1
+4 IF $DATA(RVAR)
SET LDAT(1)=$PIECE($GET(^RMPR(664.3,RVAR,0)),U)
IF LDAT(1)>LDAT(2)
SET LDAT(2)=LDAT(1)
End DoDot:1
+5 IF LDAT(2)=0
WRITE "LAST WORK DATE: "
QUIT
+6 SET Y=LDAT(2)
DO DD^%DT
WRITE "LAST WORK DATE: "_Y
+7 SET X=""
+8 QUIT
STN ;GET STATUS OF PROCUREMENT
+1 SET RAT=$PIECE($GET(^RMPR(664.1,D0,2,D1,0)),U,6)
IF +RAT
FOR RA=0:0
SET RA=$ORDER(^RMPR(664.2,+RAT,1,RA))
if RA'>0
QUIT
SET RRA=(^(RA,0))
Begin DoDot:1
+2 IF $DATA(^RMPR(664,+$PIECE(RRA,U,11),0))
IF '$PIECE(^(0),U,8)
WRITE !,?9,"2421 PURCHASE "_$PIECE(RRA,U,10)_" PENDING DELIVERY"
+3 IF $DATA(^RMPR(664.1,+$PIECE(RRA,U,13),0))
IF '$PIECE(^(0),U,26)
WRITE !,?9,"2529-3 REQUEST "_$PIECE(RRA,U,10)_" PENDING DELIVERY"
End DoDot:1
+4 SET X=""
+5 QUIT
OCLS ;DISPLAY CLOSED REMOTE 2529-3
+1 KILL QUIT
DO ST^RMPRDT
if $DATA(QUIT)
GOTO EXIT
+2 SET DIC="^RMPR(664.1,"
SET BY="@20"
SET FR=DATE(1)
SET TO=DATE(2)
SET DIS(0)="I $P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)'=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""C"""
DO FLDSC
QUIT
CLS ;CLOSED 2529-3s
+1 KILL QUIT
DO ST^RMPRDT
if $DATA(QUIT)
GOTO EXIT
+2 SET L=0
+3 SET DIC="^RMPR(664.1,"
SET BY="@20"
SET FR=DATE(1)
SET TO=DATE(2)
SET DIS(0)="I $P($G(^RMPR(664.1,D0,7)),U,2),$P(^RMPR(664.1,D0,0),U,3)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,15)=RMPR(""STA""),$P(^RMPR(664.1,D0,0),U,17)=""C"""
+4 SET FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
+5 SET FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE DELIVERED-DATE;C60;""#DAYS OPEN"";W15"
+6 SET FLDS(2)="""ASSIGNED BY:"";C1,ASSIGNED BY;C15;X,""DATE ASSIGNED"";C40,DATE ASSIGNED;X;C60"
+7 SET FLDS(3)="""WORK FOR: "";C1,2;C11;X,""ASSIGNED TO:"";C40,STRIPBLANKS(TECHNICIAN);C60;X"
+8 SET FLDS(4)="D DIS^RMPR29I;C1;X"
+9 SET FLDS(5)="6,""ITEM:"";C1;X,.01;C10;X,D LEW^RMPR29I;C40;X,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
+10 SET FLDS(6)="6,""LABOR COST:"";X;C1,5:STRIPBLANKS(TOTAL LABOR COST);X;C15,""MATERIAL COST:"";X;C24,5:STRIPBLANKS(TOTAL MATERIAL COST);X;C40,""TOTAL COST:"";X;C50,5:STRIPBLANKS(TOTAL LAB COST);X;C65"
+11 SET FLDS(7)="""DELIVERY DATE"";C1;X,20;C15;X"
+12 SET DHD=" <CLOSED 2529-3s>"
SET DHIT="D LINE^RMPR29I"
DO EN1^DIP
+13 DO EXIT
QUIT
FLDSC ;set flds array for call to dip
+1 SET FLDS="STRIPBLANKS(PATIENT);C1;""PATIENT"",.02:.01:.09;C40;""SSN"",4;C60;""WORK ORDER"""
+2 SET FLDS(1)="REQUESTING OFFICIAL;C1;""INITIATED BY"",DATE;C40;""DATE INIT"",DATE DELIVERED-DATE;C60;""#DAYS OPEN"";W15"
+3 SET FLDS(2)="""WORK FOR: "";C1,2;C11;X,D DIS^RMPR29I;C40;X"
+4 SET FLDS(3)="6,""ITEM:"";C1;X,.01;C10,D ADC^RMPR29I;X,""DESC:"";C1,7;C10;W60;X"
SET FLDS(4)="""DELIVERY DATE"";C1;X,20;C15;X"
+5 SET DHD=" <CLOSED 2529-3s>"
SET DHIT="D LINE^RMPR29I"
DO EN1^DIP
+6 DO EXIT
QUIT
