PSOERPC3 ;BIRM/MFR - All Patients (Patient Centric) Hidden Action - Supporting APIs 2 ;08/12/24
;;7.0;OUTPATIENT PHARMACY;**770**;DEC 1997;Build 145
;
CRT ; Entry point of PSO ERX ALL PATIENTS CR DEFAULT TEXT EDIT action protocol
N I,INDEX,CODE,DIR,HLP,HELP,RSONCODE,DESC,WRPHELP,REATXT,PSOQUIT,EXTRCODE,EXTSCODE,REACODE,REASCODE,CODETYPE,FINISH
N NPLEN,DWLW,DWPK,DIWESUB,REASTXT,FDARSNTXT,X,TMPCHNGE,IENS,DIWETXT
D FULL^VALM1 S VALMBCK="R"
I '$D(^XUSEC("PSDMGR",DUZ)) D G REF^PSOERPC0
. W !!,$G(IOINHI),"You do not have the appropriate key (PSDMGR) to access this option.",!,$G(IOINORM) D DIRE^PSOERXX1
;
W !!,$G(IOINHI),"Updates will apply for the ",$$GET1^DIQ(59,PSOSITE,.01)," division only.",$G(IOINORM)
;
S IENS=""
K INDEX S CODE=0 K DIR S DIR(0)="SO^",HLP=0,DIR("?")=" "
F S CODE=$O(^PS(52.45,"TYPE","MRC",CODE)) Q:'CODE D
. S RSONCODE=$$GET1^DIQ(52.45,CODE,.01)
. S INDEX(RSONCODE)=CODE
. S DIR(0)=DIR(0)_RSONCODE_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
. S HLP=HLP+1,DIR("?",HLP)=" "_RSONCODE_$S($L(RSONCODE)>1:" - ",1:" - ")
. K DESC S X=$$GET1^DIQ(52.45,CODE,1,"","DESC") I '$D(DESC) Q
. S HELP=$G(DESC(1)) F I=2:1 Q:'$D(DESC(I)) S HELP=HELP_" "_DESC(I)
. K WRPHELP D WRAP^PSOERUT(HELP,70,.WRPHELP)
. F I=1:1 Q:'$D(WRPHELP(I)) S:I>1 HLP=HLP+1 S $E(DIR("?",HLP),10)=$G(WRPHELP(I,0))
;
S DIR("A")="CHANGE REQUEST CODE" I $G(REACODE) S DIR("B")=$$GET1^DIQ(52.45,REACODE,.01)
D ^DIR I $D(DIRUT)!$D(DIROUT) G REF^PSOERPC0
I $G(REACODE)'=+$G(INDEX(Y)) S REASCODE=0,EXTSCODE="" K REATXT
S REACODE=+$G(INDEX(Y)),EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
W ! I '$D(REATXT) D
. ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
. I $$CHKDIVRSN(REACODE,.REATXT) Q
. S X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
;
S PSOQUIT=0
I (" S D U T "[(" "_EXTRCODE_" ")) D I $G(PSOQUIT) G REF^PSOERPC0
. K INDEX K DIR S DIR(0)="SO^",DIR("L",1)=" Select one of the following:",DIR("L",2)=" "
. S HLP=0,LINE=2,DIR("L")=" "_$S(EXTRCODE="D":"Type '?' for the full list. ",1:"")
. S DIR("?")="^D HELP^PSOERCR1"
. S CODETYPE=$S(EXTRCODE="S":"SCR",EXTRCODE="D":"REA",EXTRCODE="T":"TIS",1:"MRSC")
. F S CODE=$O(^PS(52.45,"TYPE",CODETYPE,CODE)) Q:'CODE D
. . S INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
. . S DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
. . ;
. . I EXTRCODE="U"!(EXTRCODE="T")!(EXTRCODE="D"&(",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"[(","_$$GET1^DIQ(52.45,CODE,.01)_","))) D
. . . S LINE=LINE+1,DIR("L",LINE)=" "_$S(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
. . S HLP=HLP+1,DIR("?",HLP)=" "_$S(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
. . ;
. . I EXTRCODE="S"&(",PRN,UDD,COD,MSD,RIJ,VEF,VLQ,VPQ,AUT,"[(","_$$GET1^DIQ(52.45,CODE,.01)_",")) D ;script clarification subcodes
. . . S LINE=LINE+1,DIR("L",LINE)=" "_$S(EXTRCODE="S":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
. . ;
. I EXTRCODE="D" S LINE=LINE+1,DIR("L",LINE)=" "
. S DIR("A")="CHANGE REQUEST SUB-CODE" I $G(REASCODE) S DIR("B")=$$GET1^DIQ(52.45,REASCODE,.01)
. D ^DIR I $D(DIRUT)!$D(DIROUT) S PSOQUIT=1 Q
. I $G(REASCODE)'=+$G(INDEX(Y)) K REATXT
. S REASCODE=+$G(INDEX(Y)),EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
. W ! I '$D(REATXT) D
. . ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
. . I $$CHKDIVRSN(REASCODE,.REATXT) Q
. . S X=$$GET1^DIQ(52.45,REASCODE,20,,"REATXT")
;
K ^TMP("PSOERPC3",$J)
F I=1:1 Q:'$D(REATXT(I)) S ^TMP("PSOERPC3",$J,I,0)=REATXT(I)
S (PSOQUIT,TMPCHNGE)=0
F I=1:1 S FINISH=1 D I FINISH!PSOQUIT Q
. S NPLEN=0,DIC="^TMP(""PSOERPC3"""_",$J,"
. S DWLW=80,DWPK=1,DIWETXT="You are about to edit "_$$GET1^DIQ(52.45,REACODE_",",".02","E")_" "
. I EXTRCODE'="U" S DIWETXT=DIWETXT_$$GET1^DIQ(52.45,REASCODE_",",".02","E")
. S DIWETXT=DIWETXT_" Template:"
. S DIWESUB="DEFAULT NOTE TO PROVIDER" W !,DIWESUB,":"
. D EN^DIWE I $G(DUOUT) S PSOQUIT=1 Q
. F I=1:1 Q:'$D(^TMP("PSOERPC3",$J,I)) D I 'FINISH Q
. . S X=^TMP("PSOERPC3",$J,I,0)
. . S NPLEN=NPLEN+$L(X) I NPLEN>(261-$O(^TMP("PSOERPC3",$J,99),-1)) W !!,$G(IOINHI),"The maximum length for this note is 260 characters.",$G(IOINORM),$C(7) S FINISH=0 D PAUSE^PSOSPMU1 Q
. . I $D(REATXT(I)),X'=REATXT(I) S TMPCHNGE=1
. . I $D(^TMP("PSOERPC3",$J,I)),'$D(REATXT(I)) S TMPCHNGE=1
;
I +TMPCHNGE<1 W !!,$G(IOINHI),"Nothings change. No Action Taken.",$G(IOINORM),$C(7) D PAUSE^PSOSPMU1 G REF^PSOERPC0
I PSOQUIT G REF^PSOERPC0
K REASTXT F I=1:1 Q:'$D(^TMP("PSOERPC3",$J,I)) S REASTXT(I,0)=$G(^TMP("PSOERPC3",$J,I,0))
K FDARSNTXT
I +TMPCHNGE>0 D ;
. I $G(IENS)="" S IENS="+1,"_$S((" D U S "'[(" "_EXTRCODE_" ")):REACODE,1:REASCODE)_","
. S FDARSNTXT(52.4521,IENS,.01)=$G(PSOSITE)
. S FDARSNTXT(52.4521,IENS,1)="REASTXT"
E S FDARSNTXT(52.45,REASCODE_",",20)="REASTXT"
K DIERR D UPDATE^DIE("","FDARSNTXT",,"DIERR")
I $D(DIERR) W !!,$G(IOINHI),"Error while updating the data: "_$G(DIERR("DIERR",1,"TEXT",1)),$G(IOINORM),$C(7) D PAUSE^PSOSPMU1
E W !!,$G(IOINHI),"Update successful for "_$$GET1^DIQ(59,PSOSITE,.01)," division.",$G(IOINORM),$C(7) D PAUSE^PSOSPMU1
K ^TMP("PSOERPC3",$J)
G REF^PSOERPC0
Q
;
CHKDIVRSN(RSNIEN,DIVREATXT) ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
;Input : RSNIEN - Pointer to ERX SERVICE REASON CODES file (#52.45)
;Outputs: CHKDIVRSN - Return 1 if the division set a specific change request reason in field 21. Otherwise,0
; DIVREATXT - Array Containing Division Specific Reason Text
N IENS,X
Q:'$G(RSNIEN)!'$G(PSOSITE)
I $D(^PS(52.45,RSNIEN,21,"B",PSOSITE)) D
. S IENS=$O(^PS(52.45,RSNIEN,21,"B",PSOSITE,""),-1)_","_RSNIEN_"," ;get the last entry change
. I $G(IENS) S X=$$GET1^DIQ(52.4521,IENS,1,,"DIVREATXT")
Q $S($D(DIVREATXT):1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOERPC3 6094 printed Aug 26, 2025@22:43:49 Page 2
PSOERPC3 ;BIRM/MFR - All Patients (Patient Centric) Hidden Action - Supporting APIs 2 ;08/12/24
+1 ;;7.0;OUTPATIENT PHARMACY;**770**;DEC 1997;Build 145
+2 ;
CRT ; Entry point of PSO ERX ALL PATIENTS CR DEFAULT TEXT EDIT action protocol
+1 NEW I,INDEX,CODE,DIR,HLP,HELP,RSONCODE,DESC,WRPHELP,REATXT,PSOQUIT,EXTRCODE,EXTSCODE,REACODE,REASCODE,CODETYPE,FINISH
+2 NEW NPLEN,DWLW,DWPK,DIWESUB,REASTXT,FDARSNTXT,X,TMPCHNGE,IENS,DIWETXT
+3 DO FULL^VALM1
SET VALMBCK="R"
+4 IF '$DATA(^XUSEC("PSDMGR",DUZ))
Begin DoDot:1
+5 WRITE !!,$GET(IOINHI),"You do not have the appropriate key (PSDMGR) to access this option.",!,$GET(IOINORM)
DO DIRE^PSOERXX1
End DoDot:1
GOTO REF^PSOERPC0
+6 ;
+7 WRITE !!,$GET(IOINHI),"Updates will apply for the ",$$GET1^DIQ(59,PSOSITE,.01)," division only.",$GET(IOINORM)
+8 ;
+9 SET IENS=""
+10 KILL INDEX
SET CODE=0
KILL DIR
SET DIR(0)="SO^"
SET HLP=0
SET DIR("?")=" "
+11 FOR
SET CODE=$ORDER(^PS(52.45,"TYPE","MRC",CODE))
if 'CODE
QUIT
Begin DoDot:1
+12 SET RSONCODE=$$GET1^DIQ(52.45,CODE,.01)
+13 SET INDEX(RSONCODE)=CODE
+14 SET DIR(0)=DIR(0)_RSONCODE_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
+15 SET HLP=HLP+1
SET DIR("?",HLP)=" "_RSONCODE_$SELECT($LENGTH(RSONCODE)>1:" - ",1:" - ")
+16 KILL DESC
SET X=$$GET1^DIQ(52.45,CODE,1,"","DESC")
IF '$DATA(DESC)
QUIT
+17 SET HELP=$GET(DESC(1))
FOR I=2:1
if '$DATA(DESC(I))
QUIT
SET HELP=HELP_" "_DESC(I)
+18 KILL WRPHELP
DO WRAP^PSOERUT(HELP,70,.WRPHELP)
+19 FOR I=1:1
if '$DATA(WRPHELP(I))
QUIT
if I>1
SET HLP=HLP+1
SET $EXTRACT(DIR("?",HLP),10)=$GET(WRPHELP(I,0))
End DoDot:1
+20 ;
+21 SET DIR("A")="CHANGE REQUEST CODE"
IF $GET(REACODE)
SET DIR("B")=$$GET1^DIQ(52.45,REACODE,.01)
+22 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
GOTO REF^PSOERPC0
+23 IF $GET(REACODE)'=+$GET(INDEX(Y))
SET REASCODE=0
SET EXTSCODE=""
KILL REATXT
+24 SET REACODE=+$GET(INDEX(Y))
SET EXTRCODE=$$GET1^DIQ(52.45,REACODE,.01)
+25 WRITE !
IF '$DATA(REATXT)
Begin DoDot:1
+26 ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
+27 IF $$CHKDIVRSN(REACODE,.REATXT)
QUIT
+28 SET X=$$GET1^DIQ(52.45,REACODE,20,,"REATXT")
End DoDot:1
+29 ;
+30 SET PSOQUIT=0
+31 IF (" S D U T "[(" "_EXTRCODE_" "))
Begin DoDot:1
+32 KILL INDEX
KILL DIR
SET DIR(0)="SO^"
SET DIR("L",1)=" Select one of the following:"
SET DIR("L",2)=" "
+33 SET HLP=0
SET LINE=2
SET DIR("L")=" "_$SELECT(EXTRCODE="D":"Type '?' for the full list. ",1:"")
+34 SET DIR("?")="^D HELP^PSOERCR1"
+35 SET CODETYPE=$SELECT(EXTRCODE="S":"SCR",EXTRCODE="D":"REA",EXTRCODE="T":"TIS",1:"MRSC")
+36 FOR
SET CODE=$ORDER(^PS(52.45,"TYPE",CODETYPE,CODE))
if 'CODE
QUIT
Begin DoDot:2
+37 SET INDEX($$GET1^DIQ(52.45,CODE,.01))=CODE
+38 SET DIR(0)=DIR(0)_$$GET1^DIQ(52.45,CODE,.01)_":"_$$GET1^DIQ(52.45,CODE,.02)_";"
+39 ;
+40 IF EXTRCODE="U"!(EXTRCODE="T")!(EXTRCODE="D"&(",DA,DD,HD,LD,MS,TD,AR,DI,DR,ID,UD,PS,SX,TP,"[(","_$$GET1^DIQ(52.45,CODE,.01)_",")))
Begin DoDot:3
+41 SET LINE=LINE+1
SET DIR("L",LINE)=" "_$SELECT(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
End DoDot:3
+42 SET HLP=HLP+1
SET DIR("?",HLP)=" "_$SELECT(EXTRCODE="D":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
+43 ;
+44 ;script clarification subcodes
IF EXTRCODE="S"&(",PRN,UDD,COD,MSD,RIJ,VEF,VLQ,VPQ,AUT,"[(","_$$GET1^DIQ(52.45,CODE,.01)_","))
Begin DoDot:3
+45 SET LINE=LINE+1
SET DIR("L",LINE)=" "_$SELECT(EXTRCODE="S":" ",1:"")_$$GET1^DIQ(52.45,CODE,.01)_" - "_$$GET1^DIQ(52.45,CODE,.02)
End DoDot:3
+46 ;
End DoDot:2
+47 IF EXTRCODE="D"
SET LINE=LINE+1
SET DIR("L",LINE)=" "
+48 SET DIR("A")="CHANGE REQUEST SUB-CODE"
IF $GET(REASCODE)
SET DIR("B")=$$GET1^DIQ(52.45,REASCODE,.01)
+49 DO ^DIR
IF $DATA(DIRUT)!$DATA(DIROUT)
SET PSOQUIT=1
QUIT
+50 IF $GET(REASCODE)'=+$GET(INDEX(Y))
KILL REATXT
+51 SET REASCODE=+$GET(INDEX(Y))
SET EXTSCODE=$$GET1^DIQ(52.45,REASCODE,.01)
+52 WRITE !
IF '$DATA(REATXT)
Begin DoDot:2
+53 ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
+54 IF $$CHKDIVRSN(REASCODE,.REATXT)
QUIT
+55 SET X=$$GET1^DIQ(52.45,REASCODE,20,,"REATXT")
End DoDot:2
End DoDot:1
IF $GET(PSOQUIT)
GOTO REF^PSOERPC0
+56 ;
+57 KILL ^TMP("PSOERPC3",$JOB)
+58 FOR I=1:1
if '$DATA(REATXT(I))
QUIT
SET ^TMP("PSOERPC3",$JOB,I,0)=REATXT(I)
+59 SET (PSOQUIT,TMPCHNGE)=0
+60 FOR I=1:1
SET FINISH=1
Begin DoDot:1
+61 SET NPLEN=0
SET DIC="^TMP(""PSOERPC3"""_",$J,"
+62 SET DWLW=80
SET DWPK=1
SET DIWETXT="You are about to edit "_$$GET1^DIQ(52.45,REACODE_",",".02","E")_" "
+63 IF EXTRCODE'="U"
SET DIWETXT=DIWETXT_$$GET1^DIQ(52.45,REASCODE_",",".02","E")
+64 SET DIWETXT=DIWETXT_" Template:"
+65 SET DIWESUB="DEFAULT NOTE TO PROVIDER"
WRITE !,DIWESUB,":"
+66 DO EN^DIWE
IF $GET(DUOUT)
SET PSOQUIT=1
QUIT
+67 FOR I=1:1
if '$DATA(^TMP("PSOERPC3",$JOB,I))
QUIT
Begin DoDot:2
+68 SET X=^TMP("PSOERPC3",$JOB,I,0)
+69 SET NPLEN=NPLEN+$LENGTH(X)
IF NPLEN>(261-$ORDER(^TMP("PSOERPC3",$JOB,99),-1))
WRITE !!,$GET(IOINHI),"The maximum length for this note is 260 characters.",$GET(IOINORM),$CHAR(7)
SET FINISH=0
DO PAUSE^PSOSPMU1
QUIT
+70 IF $DATA(REATXT(I))
IF X'=REATXT(I)
SET TMPCHNGE=1
+71 IF $DATA(^TMP("PSOERPC3",$JOB,I))
IF '$DATA(REATXT(I))
SET TMPCHNGE=1
End DoDot:2
IF 'FINISH
QUIT
End DoDot:1
IF FINISH!PSOQUIT
QUIT
+72 ;
+73 IF +TMPCHNGE<1
WRITE !!,$GET(IOINHI),"Nothings change. No Action Taken.",$GET(IOINORM),$CHAR(7)
DO PAUSE^PSOSPMU1
GOTO REF^PSOERPC0
+74 IF PSOQUIT
GOTO REF^PSOERPC0
+75 KILL REASTXT
FOR I=1:1
if '$DATA(^TMP("PSOERPC3",$JOB,I))
QUIT
SET REASTXT(I,0)=$GET(^TMP("PSOERPC3",$JOB,I,0))
+76 KILL FDARSNTXT
+77 ;
IF +TMPCHNGE>0
Begin DoDot:1
+78 IF $GET(IENS)=""
SET IENS="+1,"_$SELECT((" D U S "'[(" "_EXTRCODE_" ")):REACODE,1:REASCODE)_","
+79 SET FDARSNTXT(52.4521,IENS,.01)=$GET(PSOSITE)
+80 SET FDARSNTXT(52.4521,IENS,1)="REASTXT"
End DoDot:1
+81 IF '$TEST
SET FDARSNTXT(52.45,REASCODE_",",20)="REASTXT"
+82 KILL DIERR
DO UPDATE^DIE("","FDARSNTXT",,"DIERR")
+83 IF $DATA(DIERR)
WRITE !!,$GET(IOINHI),"Error while updating the data: "_$GET(DIERR("DIERR",1,"TEXT",1)),$GET(IOINORM),$CHAR(7)
DO PAUSE^PSOSPMU1
+84 IF '$TEST
WRITE !!,$GET(IOINHI),"Update successful for "_$$GET1^DIQ(59,PSOSITE,.01)," division.",$GET(IOINORM),$CHAR(7)
DO PAUSE^PSOSPMU1
+85 KILL ^TMP("PSOERPC3",$JOB)
+86 GOTO REF^PSOERPC0
+87 QUIT
+88 ;
CHKDIVRSN(RSNIEN,DIVREATXT) ;check if the division set a specific change request reason in field 21. Otherwise, display the default text in field 20.
+1 ;Input : RSNIEN - Pointer to ERX SERVICE REASON CODES file (#52.45)
+2 ;Outputs: CHKDIVRSN - Return 1 if the division set a specific change request reason in field 21. Otherwise,0
+3 ; DIVREATXT - Array Containing Division Specific Reason Text
+4 NEW IENS,X
+5 if '$GET(RSNIEN)!'$GET(PSOSITE)
QUIT
+6 IF $DATA(^PS(52.45,RSNIEN,21,"B",PSOSITE))
Begin DoDot:1
+7 ;get the last entry change
SET IENS=$ORDER(^PS(52.45,RSNIEN,21,"B",PSOSITE,""),-1)_","_RSNIEN_","
+8 IF $GET(IENS)
SET X=$$GET1^DIQ(52.4521,IENS,1,,"DIVREATXT")
End DoDot:1
+9 QUIT $SELECT($DATA(DIVREATXT):1,1:0)
