- 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 Jan 18, 2025@03:33:20 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