PSOBPSS2 ;AITC/MRD - ePharmacy Site Parameters Definition Cont. ;02/24/2021
;;7.0;OUTPATIENT PHARMACY;**562**;DEC 1997;Build 19
;
EDITALL ; Action for EA Edit All Parameters
;
; Local variable
; RET - for control after return from call - if "^" then call RBUILD and quit
N RET S RET=""
;
; Call to General Parameter Edit
D EDITGEN(.RET)
I RET=U D RBUILD^PSOBPSSP Q
;
; Call to Transfer Reject Code Edit
D EDITTRC(.RET)
I RET=U D RBUILD^PSOBPSSP Q
;
; Call to Reject Resolution Required Code Edit
D EDITRRRC
;
D RBUILD^PSOBPSSP
Q
;
EDITGEN(RETURN) ; Action for EG Edit General Parameters
;
; Input Parameter
; RETURN - Null if normal exit, "^" if timeout or "^" entered
;
; Variables used by DIE
N DIE,DA,DIC,DUOUT,DTOUT,DEF
;
; Set Full Screen mode
D FULL^VALM1
;
; Get worklist days & update the record
S DIE="^PS(52.86,",DA=PSOBPSDV,DR="4" D ^DIE
; CHECK FOR TIMEOUT OR ^
I $G(DTOUT)!$D(Y) S RETURN="^"
;
; Update EPHARMACY RESPONSE PAUSE
K DTOUT,DUOUT
S DEF=$$GET1^DIQ(52.86,PSOBPSDV_",",6,"I")
I DEF="" S DEF=2
S DIE="^PS(52.86,",DA=PSOBPSDV,DR="6//"_DEF D ^DIE
; CHECK FOR TIMEOUT OR ^
I $G(DTOUT)!$D(Y) S RETURN="^"
;
; Get IGNORE THRESHOLD & update the record
S DIE="^PS(52.86,",DA=PSOBPSDV,DR="7" D ^DIE
; CHECK FOR TIMEOUT OR ^
I $G(DTOUT)!$D(Y) S RETURN="^"
D RBUILD^PSOBPSSP
Q
;
EDITTRC(RETURN) ; Action for ET Edit Transfer Reject Code
;
; Input Parameter
; RETURN - Null if normal exit, "^" if timeout or "^" entered
;
; From EN
; PSOBPSDV - current division declared in EN
;
; Local Variables
; PASS1 - used to indicate first pass through edit loop for controlling reject prompt
; QT - indicates the loop processing can quit
;
; Set Full Screen mode
D FULL^VALM1
;
N QT,PASS1
S QT=0,PASS1=1
;
; Informational message
D TRCMSG^PSOBPSSL
;
; Loop through Reject Code edits
F Q:QT D
. ; DIE,DA,DIC,DUOUT,DTOUT,DIR,DIC,X,Y - Used by FileMan
. N DIE,DR,DA,DUOUT,DTOUT,DIR,DIC,Y,X
. ; Variables local to this loop
. ; REJCODE - External Reject code - .01 field from 9002312.93
. ; REJIEN - Reject code IEN from 9002312.93
. ; ADD - Flag indicating a new code was selected
. ; NEWCDPTR - IEN of the Reject Code in 9002313.92 when the user changed the Reject Code
. ;
. N REJCODE,REJIEN,ADD,NEWCDPTR
. ;
. ; Set up and call Lookup (^DIC)
. S DIC("A")=$S(PASS1:"",1:"ANOTHER ")_"TRANSFER REJECT CODE: ",PASS1=0
. S DIC=9002313.93
. S DIC(0)="QEAZ"
. S DIC("S")="I '$F("".79.88.943."","".""_$P($G(^(0)),U,1)_""."")"
. W ! D ^DIC
. ;
. ; Check responses to the lookup
. I $G(DUOUT)!($G(DTOUT)) S RETURN=U,QT=1 Q ; user entered a ^, or timed out
. I Y'>0 S QT=1 Q ; user entered a blank to get out
. ;
. S REJIEN=+Y,REJCODE=$P(Y,U,2)
. S ADD=0
. ;
. ; if new code, set up new node
. I '$D(^PS(52.86,PSOBPSDV,1,"B",REJIEN)) D
. . ; TRCFDA - FDA structure used by UPDATE^DIE
. . N TRCFDA
. . S ADD=1
. . ;
. . ;Set up FDA and File the data
. . S TRCFDA(52.8651,"+1,"_PSOBPSDV_",",.01)=REJIEN
. . S TRCFDA(52.8651,"+1,"_PSOBPSDV_",",1)=0 ; Default AUTO SEND
. . D UPDATE^DIE(,"TRCFDA")
. . Q
. ;
. ; Edit the transfer reject code entry
. S DA=$O(^PS(52.86,PSOBPSDV,1,"B",REJIEN,0)) Q:'DA
. S DA(1)=PSOBPSDV
. S DIE="^PS(52.86,"_DA(1)_",1,"
. S DR=".01"
. I ADD W !!?3,"You are entering a new transfer reject code - "_REJCODE_"."
. E W !!?3,"You are editing an existing transfer reject code - "_REJCODE_"."
. D ^DIE
. ;
. I '$G(DA) Q ; user deleted it so we're done
. I $G(DTOUT) S RETURN=U,QT=1 Q ; timeout - exit loop
. I $D(Y) S RETURN=U,QT=1 Q ; user entered a ^ to exit loop
. ;
. ; If the user changed the reject code, check for duplicate OR 79/88/943
. ; Get the current pointer filed by DIE and compare it to the original pointer
. S DA=+$G(DA),NEWCDPTR=$P($G(^PS(52.86,PSOBPSDV,1,DA,0)),U,1)
. I NEWCDPTR'=REJIEN D
. . ; CTR - used in duplicate check. # of records with same code value
. . ; IEN - used when checking the "B" index for duplicates using $ORDER
. . N CTR,IEN
. . ; NEWCDPTR - holds the new reject code after the user changes it
. . S (CTR,IEN)=0
. . F S IEN=$O(^PS(52.86,PSOBPSDV,1,"B",NEWCDPTR,IEN)) Q:'IEN S CTR=CTR+1
. . I CTR>1 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"You selected a duplicate reject code. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=79 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Code '79/RTS' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=88 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Reject code '88/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=943 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Reject code '943/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . Q
. ; NEWCDPTR will be 0 if the user tried to enter an invalid or duplicate reject code
. Q:'NEWCDPTR
. ;
. ; Now edit the AUTO SAVE parameter
. S DA(1)=PSOBPSDV
. S DIE="^PS(52.86,"_DA(1)_",1,"
. S DR="1"
. D ^DIE
. ;
. I $G(DTOUT) S RETURN=U,QT=1 Q ; timeout - exit loop
. I $D(Y) S RETURN=U,QT=1 Q ; user entered a ^ to exit loop
. Q
. ;
S VALMBG=1
D RBUILD^PSOBPSSP
Q
;
EDITRRRC ; Action for ER Edit Reject Resolution Required Code
;
; Input Parameter
; RETURN - Null if normal exit, "^" if timeout or "^" entered
;
; From EN
; PSOBPSDV - current division declared in EN
;
; Local Variables
; PASS1 - used to indicate first pass through edit loop for controlling reject prompt
; QT - indicates the loop processing can quit
;
; Set Full Screen mode
D FULL^VALM1
;
N QT,PASS1
S QT=0,PASS1=1
;
; Informational message
D RRRMSG^PSOBPSSL
;
; Loop through Reject Code edits
F Q:QT D
. ; DIE,DA,DIC,DUOUT,DTOUT,DIR,DIC,X,Y - Used by FileMan
. N DIE,DR,DA,DUOUT,DTOUT,DIR,DIC,Y,X
. ; Variables local to this loop
. ; REJCODE - External Reject code - .01 field from 9002312.93
. ; REJIEN - Reject code IEN from 9002312.93
. ; ADD - Flag indicating a new code was selected
. ; NEWCDPTR - IEN of the Reject Code in 9002313.92 when the user changed the Reject Code
. ;
. N REJCODE,REJIEN,ADD,NEWCDPTR
. ;
. ; Set up and call Lookup (^DIC)
. S DIC("A")=$S(PASS1:"",1:"ANOTHER ")_"REJECT RESOLUTION REQUIRED CODE: ",PASS1=0
. S DIC=9002313.93
. S DIC(0)="QEAZ"
. S DIC("S")="I '$F("".79.88.943."","".""_$P($G(^(0)),U,1)_""."")"
. W ! D ^DIC
. ;
. ; Check responses to the lookup
. I $G(DUOUT)!($G(DTOUT)) S RETURN=U,QT=1 Q ; user entered a ^, or timed out
. I Y'>0 S QT=1 Q ; user entered a blank to get out
. ;
. S REJIEN=+Y,REJCODE=$P(Y,U,2)
. S ADD=0
. ;
. ; if new code, set up new node
. I '$D(^PS(52.86,PSOBPSDV,5,"B",REJIEN)) D
. . ; RRRCFDA - FDA structure used by UPDATE^DIE
. . N RRRCFDA
. . S ADD=1
. . ;
. . ;Set up FDA and File the data
. . S RRRCFDA(52.865,"+1,"_PSOBPSDV_",",.01)=REJIEN
. . S RRRCFDA(52.865,"+1,"_PSOBPSDV_",",.02)=0 ; Default DOLLAR THRESHOLD
. . D UPDATE^DIE(,"RRRCFDA")
. . Q
. ;
. ; Edit the transfer reject code entry
. S DA=$O(^PS(52.86,PSOBPSDV,5,"B",REJIEN,0)) Q:'DA
. S DA(1)=PSOBPSDV
. S DIE="^PS(52.86,"_DA(1)_",5,"
. S DR=".01REJECT RESOLUTION REQUIRED CODE"
. I ADD W !!?3,"You are entering a new reject resolution required code - "_REJCODE_"."
. E W !!?3,"You are editing an existing reject resolution required code - "_REJCODE_"."
. D ^DIE
. ;
. I '$G(DA) Q ; user deleted it so we're done
. I $G(DTOUT) S RETURN=U,QT=1 Q ; timeout - exit loop
. I $D(Y) S RETURN=U,QT=1 Q ; user entered a ^ to exit loop
. ;
. ; If the user changed the reject code, check for duplicate OR 79/88/943
. ; Get the current pointer filed by DIE and compare it to the original pointer
. S DA=+$G(DA),NEWCDPTR=$P($G(^PS(52.86,PSOBPSDV,5,DA,0)),U,1)
. I NEWCDPTR'=REJIEN D
. . ; CTR - used in duplicate check. # of records with same code value
. . ; IEN - used when checking the "B" index for duplicates using $ORDER
. . N CTR,IEN
. . ; NEWCDPTR - holds the new reject code after the user changes it
. . S (CTR,IEN)=0
. . F S IEN=$O(^PS(52.86,PSOBPSDV,5,"B",NEWCDPTR,IEN)) Q:'IEN S CTR=CTR+1
. . I CTR>1 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"You selected a duplicate reject code. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=79 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Code '79/RTS' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=88 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Reject code '88/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . I $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=943 D Q
. . . S DR=".01////"_REJIEN D ^DIE ; restore the code pointer
. . . W !!?3,"Reject code '943/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
. . . S NEWCDPTR=0 ; Clear the new pointer if it is no longer valid
. . . Q
. . Q
. ; NEWCDPTR will be 0 if the user tried to enter an invalid or duplicate reject code
. Q:'NEWCDPTR
. ;
. ; Now edit the DOLLAR THRESHOLD parameter
. S DA(1)=PSOBPSDV
. S DIE="^PS(52.86,"_DA(1)_",5,"
. S DR=".02"
. D ^DIE
. ; Make sure stored value is not null
. I '$G(DTOUT),$G(^PS(52.86,PSOBPSDV,5,DA,0)) D
. . S $P(^PS(52.86,PSOBPSDV,5,DA,0),U,2)=+$P(^PS(52.86,PSOBPSDV,5,DA,0),U,2)
. ;
. I $G(DTOUT) S RETURN=U,QT=1 Q ; timeout - exit loop
. I $D(Y) S RETURN=U,QT=1 Q ; user entered a ^ to exit loop
. Q
. ;
S VALMBG=1
D RBUILD^PSOBPSSP
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOBPSS2 10627 printed Apr 09, 2024@21:32:42 Page 2
PSOBPSS2 ;AITC/MRD - ePharmacy Site Parameters Definition Cont. ;02/24/2021
+1 ;;7.0;OUTPATIENT PHARMACY;**562**;DEC 1997;Build 19
+2 ;
EDITALL ; Action for EA Edit All Parameters
+1 ;
+2 ; Local variable
+3 ; RET - for control after return from call - if "^" then call RBUILD and quit
+4 NEW RET
SET RET=""
+5 ;
+6 ; Call to General Parameter Edit
+7 DO EDITGEN(.RET)
+8 IF RET=U
DO RBUILD^PSOBPSSP
QUIT
+9 ;
+10 ; Call to Transfer Reject Code Edit
+11 DO EDITTRC(.RET)
+12 IF RET=U
DO RBUILD^PSOBPSSP
QUIT
+13 ;
+14 ; Call to Reject Resolution Required Code Edit
+15 DO EDITRRRC
+16 ;
+17 DO RBUILD^PSOBPSSP
+18 QUIT
+19 ;
EDITGEN(RETURN) ; Action for EG Edit General Parameters
+1 ;
+2 ; Input Parameter
+3 ; RETURN - Null if normal exit, "^" if timeout or "^" entered
+4 ;
+5 ; Variables used by DIE
+6 NEW DIE,DA,DIC,DUOUT,DTOUT,DEF
+7 ;
+8 ; Set Full Screen mode
+9 DO FULL^VALM1
+10 ;
+11 ; Get worklist days & update the record
+12 SET DIE="^PS(52.86,"
SET DA=PSOBPSDV
SET DR="4"
DO ^DIE
+13 ; CHECK FOR TIMEOUT OR ^
+14 IF $GET(DTOUT)!$DATA(Y)
SET RETURN="^"
+15 ;
+16 ; Update EPHARMACY RESPONSE PAUSE
+17 KILL DTOUT,DUOUT
+18 SET DEF=$$GET1^DIQ(52.86,PSOBPSDV_",",6,"I")
+19 IF DEF=""
SET DEF=2
+20 SET DIE="^PS(52.86,"
SET DA=PSOBPSDV
SET DR="6//"_DEF
DO ^DIE
+21 ; CHECK FOR TIMEOUT OR ^
+22 IF $GET(DTOUT)!$DATA(Y)
SET RETURN="^"
+23 ;
+24 ; Get IGNORE THRESHOLD & update the record
+25 SET DIE="^PS(52.86,"
SET DA=PSOBPSDV
SET DR="7"
DO ^DIE
+26 ; CHECK FOR TIMEOUT OR ^
+27 IF $GET(DTOUT)!$DATA(Y)
SET RETURN="^"
+28 DO RBUILD^PSOBPSSP
+29 QUIT
+30 ;
EDITTRC(RETURN) ; Action for ET Edit Transfer Reject Code
+1 ;
+2 ; Input Parameter
+3 ; RETURN - Null if normal exit, "^" if timeout or "^" entered
+4 ;
+5 ; From EN
+6 ; PSOBPSDV - current division declared in EN
+7 ;
+8 ; Local Variables
+9 ; PASS1 - used to indicate first pass through edit loop for controlling reject prompt
+10 ; QT - indicates the loop processing can quit
+11 ;
+12 ; Set Full Screen mode
+13 DO FULL^VALM1
+14 ;
+15 NEW QT,PASS1
+16 SET QT=0
SET PASS1=1
+17 ;
+18 ; Informational message
+19 DO TRCMSG^PSOBPSSL
+20 ;
+21 ; Loop through Reject Code edits
+22 FOR
if QT
QUIT
Begin DoDot:1
+23 ; DIE,DA,DIC,DUOUT,DTOUT,DIR,DIC,X,Y - Used by FileMan
+24 NEW DIE,DR,DA,DUOUT,DTOUT,DIR,DIC,Y,X
+25 ; Variables local to this loop
+26 ; REJCODE - External Reject code - .01 field from 9002312.93
+27 ; REJIEN - Reject code IEN from 9002312.93
+28 ; ADD - Flag indicating a new code was selected
+29 ; NEWCDPTR - IEN of the Reject Code in 9002313.92 when the user changed the Reject Code
+30 ;
+31 NEW REJCODE,REJIEN,ADD,NEWCDPTR
+32 ;
+33 ; Set up and call Lookup (^DIC)
+34 SET DIC("A")=$SELECT(PASS1:"",1:"ANOTHER ")_"TRANSFER REJECT CODE: "
SET PASS1=0
+35 SET DIC=9002313.93
+36 SET DIC(0)="QEAZ"
+37 SET DIC("S")="I '$F("".79.88.943."","".""_$P($G(^(0)),U,1)_""."")"
+38 WRITE !
DO ^DIC
+39 ;
+40 ; Check responses to the lookup
+41 ; user entered a ^, or timed out
IF $GET(DUOUT)!($GET(DTOUT))
SET RETURN=U
SET QT=1
QUIT
+42 ; user entered a blank to get out
IF Y'>0
SET QT=1
QUIT
+43 ;
+44 SET REJIEN=+Y
SET REJCODE=$PIECE(Y,U,2)
+45 SET ADD=0
+46 ;
+47 ; if new code, set up new node
+48 IF '$DATA(^PS(52.86,PSOBPSDV,1,"B",REJIEN))
Begin DoDot:2
+49 ; TRCFDA - FDA structure used by UPDATE^DIE
+50 NEW TRCFDA
+51 SET ADD=1
+52 ;
+53 ;Set up FDA and File the data
+54 SET TRCFDA(52.8651,"+1,"_PSOBPSDV_",",.01)=REJIEN
+55 ; Default AUTO SEND
SET TRCFDA(52.8651,"+1,"_PSOBPSDV_",",1)=0
+56 DO UPDATE^DIE(,"TRCFDA")
+57 QUIT
End DoDot:2
+58 ;
+59 ; Edit the transfer reject code entry
+60 SET DA=$ORDER(^PS(52.86,PSOBPSDV,1,"B",REJIEN,0))
if 'DA
QUIT
+61 SET DA(1)=PSOBPSDV
+62 SET DIE="^PS(52.86,"_DA(1)_",1,"
+63 SET DR=".01"
+64 IF ADD
WRITE !!?3,"You are entering a new transfer reject code - "_REJCODE_"."
+65 IF '$TEST
WRITE !!?3,"You are editing an existing transfer reject code - "_REJCODE_"."
+66 DO ^DIE
+67 ;
+68 ; user deleted it so we're done
IF '$GET(DA)
QUIT
+69 ; timeout - exit loop
IF $GET(DTOUT)
SET RETURN=U
SET QT=1
QUIT
+70 ; user entered a ^ to exit loop
IF $DATA(Y)
SET RETURN=U
SET QT=1
QUIT
+71 ;
+72 ; If the user changed the reject code, check for duplicate OR 79/88/943
+73 ; Get the current pointer filed by DIE and compare it to the original pointer
+74 SET DA=+$GET(DA)
SET NEWCDPTR=$PIECE($GET(^PS(52.86,PSOBPSDV,1,DA,0)),U,1)
+75 IF NEWCDPTR'=REJIEN
Begin DoDot:2
+76 ; CTR - used in duplicate check. # of records with same code value
+77 ; IEN - used when checking the "B" index for duplicates using $ORDER
+78 NEW CTR,IEN
+79 ; NEWCDPTR - holds the new reject code after the user changes it
+80 SET (CTR,IEN)=0
+81 FOR
SET IEN=$ORDER(^PS(52.86,PSOBPSDV,1,"B",NEWCDPTR,IEN))
if 'IEN
QUIT
SET CTR=CTR+1
+82 IF CTR>1
Begin DoDot:3
+83 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+84 WRITE !!?3,"You selected a duplicate reject code. Code '"_REJCODE_"' has been restored."
+85 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+86 QUIT
End DoDot:3
QUIT
+87 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=79
Begin DoDot:3
+88 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+89 WRITE !!?3,"Code '79/RTS' is not valid here. Code '"_REJCODE_"' has been restored."
+90 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+91 QUIT
End DoDot:3
QUIT
+92 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=88
Begin DoDot:3
+93 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+94 WRITE !!?3,"Reject code '88/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
+95 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+96 QUIT
End DoDot:3
QUIT
+97 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=943
Begin DoDot:3
+98 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+99 WRITE !!?3,"Reject code '943/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
+100 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+101 QUIT
End DoDot:3
QUIT
+102 QUIT
End DoDot:2
+103 ; NEWCDPTR will be 0 if the user tried to enter an invalid or duplicate reject code
+104 if 'NEWCDPTR
QUIT
+105 ;
+106 ; Now edit the AUTO SAVE parameter
+107 SET DA(1)=PSOBPSDV
+108 SET DIE="^PS(52.86,"_DA(1)_",1,"
+109 SET DR="1"
+110 DO ^DIE
+111 ;
+112 ; timeout - exit loop
IF $GET(DTOUT)
SET RETURN=U
SET QT=1
QUIT
+113 ; user entered a ^ to exit loop
IF $DATA(Y)
SET RETURN=U
SET QT=1
QUIT
+114 QUIT
+115 ;
End DoDot:1
+116 SET VALMBG=1
+117 DO RBUILD^PSOBPSSP
+118 QUIT
+119 ;
EDITRRRC ; Action for ER Edit Reject Resolution Required Code
+1 ;
+2 ; Input Parameter
+3 ; RETURN - Null if normal exit, "^" if timeout or "^" entered
+4 ;
+5 ; From EN
+6 ; PSOBPSDV - current division declared in EN
+7 ;
+8 ; Local Variables
+9 ; PASS1 - used to indicate first pass through edit loop for controlling reject prompt
+10 ; QT - indicates the loop processing can quit
+11 ;
+12 ; Set Full Screen mode
+13 DO FULL^VALM1
+14 ;
+15 NEW QT,PASS1
+16 SET QT=0
SET PASS1=1
+17 ;
+18 ; Informational message
+19 DO RRRMSG^PSOBPSSL
+20 ;
+21 ; Loop through Reject Code edits
+22 FOR
if QT
QUIT
Begin DoDot:1
+23 ; DIE,DA,DIC,DUOUT,DTOUT,DIR,DIC,X,Y - Used by FileMan
+24 NEW DIE,DR,DA,DUOUT,DTOUT,DIR,DIC,Y,X
+25 ; Variables local to this loop
+26 ; REJCODE - External Reject code - .01 field from 9002312.93
+27 ; REJIEN - Reject code IEN from 9002312.93
+28 ; ADD - Flag indicating a new code was selected
+29 ; NEWCDPTR - IEN of the Reject Code in 9002313.92 when the user changed the Reject Code
+30 ;
+31 NEW REJCODE,REJIEN,ADD,NEWCDPTR
+32 ;
+33 ; Set up and call Lookup (^DIC)
+34 SET DIC("A")=$SELECT(PASS1:"",1:"ANOTHER ")_"REJECT RESOLUTION REQUIRED CODE: "
SET PASS1=0
+35 SET DIC=9002313.93
+36 SET DIC(0)="QEAZ"
+37 SET DIC("S")="I '$F("".79.88.943."","".""_$P($G(^(0)),U,1)_""."")"
+38 WRITE !
DO ^DIC
+39 ;
+40 ; Check responses to the lookup
+41 ; user entered a ^, or timed out
IF $GET(DUOUT)!($GET(DTOUT))
SET RETURN=U
SET QT=1
QUIT
+42 ; user entered a blank to get out
IF Y'>0
SET QT=1
QUIT
+43 ;
+44 SET REJIEN=+Y
SET REJCODE=$PIECE(Y,U,2)
+45 SET ADD=0
+46 ;
+47 ; if new code, set up new node
+48 IF '$DATA(^PS(52.86,PSOBPSDV,5,"B",REJIEN))
Begin DoDot:2
+49 ; RRRCFDA - FDA structure used by UPDATE^DIE
+50 NEW RRRCFDA
+51 SET ADD=1
+52 ;
+53 ;Set up FDA and File the data
+54 SET RRRCFDA(52.865,"+1,"_PSOBPSDV_",",.01)=REJIEN
+55 ; Default DOLLAR THRESHOLD
SET RRRCFDA(52.865,"+1,"_PSOBPSDV_",",.02)=0
+56 DO UPDATE^DIE(,"RRRCFDA")
+57 QUIT
End DoDot:2
+58 ;
+59 ; Edit the transfer reject code entry
+60 SET DA=$ORDER(^PS(52.86,PSOBPSDV,5,"B",REJIEN,0))
if 'DA
QUIT
+61 SET DA(1)=PSOBPSDV
+62 SET DIE="^PS(52.86,"_DA(1)_",5,"
+63 SET DR=".01REJECT RESOLUTION REQUIRED CODE"
+64 IF ADD
WRITE !!?3,"You are entering a new reject resolution required code - "_REJCODE_"."
+65 IF '$TEST
WRITE !!?3,"You are editing an existing reject resolution required code - "_REJCODE_"."
+66 DO ^DIE
+67 ;
+68 ; user deleted it so we're done
IF '$GET(DA)
QUIT
+69 ; timeout - exit loop
IF $GET(DTOUT)
SET RETURN=U
SET QT=1
QUIT
+70 ; user entered a ^ to exit loop
IF $DATA(Y)
SET RETURN=U
SET QT=1
QUIT
+71 ;
+72 ; If the user changed the reject code, check for duplicate OR 79/88/943
+73 ; Get the current pointer filed by DIE and compare it to the original pointer
+74 SET DA=+$GET(DA)
SET NEWCDPTR=$PIECE($GET(^PS(52.86,PSOBPSDV,5,DA,0)),U,1)
+75 IF NEWCDPTR'=REJIEN
Begin DoDot:2
+76 ; CTR - used in duplicate check. # of records with same code value
+77 ; IEN - used when checking the "B" index for duplicates using $ORDER
+78 NEW CTR,IEN
+79 ; NEWCDPTR - holds the new reject code after the user changes it
+80 SET (CTR,IEN)=0
+81 FOR
SET IEN=$ORDER(^PS(52.86,PSOBPSDV,5,"B",NEWCDPTR,IEN))
if 'IEN
QUIT
SET CTR=CTR+1
+82 IF CTR>1
Begin DoDot:3
+83 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+84 WRITE !!?3,"You selected a duplicate reject code. Code '"_REJCODE_"' has been restored."
+85 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+86 QUIT
End DoDot:3
QUIT
+87 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=79
Begin DoDot:3
+88 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+89 WRITE !!?3,"Code '79/RTS' is not valid here. Code '"_REJCODE_"' has been restored."
+90 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+91 QUIT
End DoDot:3
QUIT
+92 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=88
Begin DoDot:3
+93 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+94 WRITE !!?3,"Reject code '88/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
+95 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+96 QUIT
End DoDot:3
QUIT
+97 IF $$GET1^DIQ(9002313.93,NEWCDPTR_",",.01)=943
Begin DoDot:3
+98 ; restore the code pointer
SET DR=".01////"_REJIEN
DO ^DIE
+99 WRITE !!?3,"Reject code '943/DUR' is not valid here. Code '"_REJCODE_"' has been restored."
+100 ; Clear the new pointer if it is no longer valid
SET NEWCDPTR=0
+101 QUIT
End DoDot:3
QUIT
+102 QUIT
End DoDot:2
+103 ; NEWCDPTR will be 0 if the user tried to enter an invalid or duplicate reject code
+104 if 'NEWCDPTR
QUIT
+105 ;
+106 ; Now edit the DOLLAR THRESHOLD parameter
+107 SET DA(1)=PSOBPSDV
+108 SET DIE="^PS(52.86,"_DA(1)_",5,"
+109 SET DR=".02"
+110 DO ^DIE
+111 ; Make sure stored value is not null
+112 IF '$GET(DTOUT)
IF $GET(^PS(52.86,PSOBPSDV,5,DA,0))
Begin DoDot:2
+113 SET $PIECE(^PS(52.86,PSOBPSDV,5,DA,0),U,2)=+$PIECE(^PS(52.86,PSOBPSDV,5,DA,0),U,2)
End DoDot:2
+114 ;
+115 ; timeout - exit loop
IF $GET(DTOUT)
SET RETURN=U
SET QT=1
QUIT
+116 ; user entered a ^ to exit loop
IF $DATA(Y)
SET RETURN=U
SET QT=1
QUIT
+117 QUIT
+118 ;
End DoDot:1
+119 SET VALMBG=1
+120 DO RBUILD^PSOBPSSP
+121 QUIT
+122 ;
