PSOSPMU2 ;BIRM/MFR - State Prescription Monitoring Program Utility #2 - Prompts ;10/07/15
;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
;
ASAPVER(DEFTYPE,REGZERO,DSPHLP,DEFAULT,REQUIRED,ALLOWDEL) ; Prompt for the ASAP Version
; Input: (r) DEFTYPE - ASAP Definition Type (S: Standard Only; C: Customized Only, F: Fully Customized Only,
; A: All. A combination is also allowed, e.g., "CF")
; (r) REGZERO - Regular or Zero Report or Both ASAP Definitions (R: Regular Only; Z: Zero Report Only;
; B: Both) ;adding new parameter for Zero Report
; (o) DSPHLP - Display Help before prompting? (1: YES / 0: NO)
; (o) DEFAULT - Default ASAP Version
; (o) REQUIRED - Is Answer Required? (1: YES / 0: NO)
; (o) ALLOWDEL - Allow delete? (accepts "@" as a valid input)
;Output: ASAPVER - ASAP Version, "^", "@" or ""
N DIR,X,Y,DTOUT,DIRUT,VERLST
;
ASK1 ; Label used in case the prompt needs to be asked again
D VERLIST^PSOSPMU0(DEFTYPE,REGZERO,.VERLST) ;Zero Report adding REGZERO
;K DIR S DIR(0)="FO^1:10",DIR("A")="ASAP VERSION" S:$G(DEFAULT)'="" DIR("B")=DEFAULT ;Zero Report
I REGZERO'["Z" D
. K DIR S DIR(0)="FO^1:10",DIR("A")="ASAP VERSION" S:$G(DEFAULT)'="" DIR("B")=DEFAULT
E D
. K DIR S DIR(0)="FO^1:10",DIR("A")="ZERO REPORT ASAP VERSION" S:$G(DEFAULT)'="" DIR("B")=DEFAULT
;
S DIR("?")="^D HLP1^PSOSPMU2(.VERLST)" I $G(DSPHLP) D HLP1^PSOSPMU2(.VERLST)
D ^DIR
I '$G(REQUIRED),X="" Q X
I $G(ALLOWDEL),X="@" Q X
I $G(REQUIRED),(X=""!(X="@")) W !,"This is a required response. Enter '^' to exit",$C(7),! G ASK1
I $D(DIRUT)!$D(DTOUT) Q "^"
I '$D(VERLST(X_" ")) W ?40,"Invalid ASAP Version",$C(7),! G ASK1
Q X
;
HLP1(VERLST) ; Help Text for ASAP Version prompt and Zero Report ASAP Version prompt
;Input: (r) VERLST - Array containing a list ASAP versions
N VER,HLPLN
I REGZERO["Z" D Q ;start Zero Report ASAP display
. W !?5,"American Society for Automation in Pharmacy (ASAP) Version for Zero"
. W !?5,"Reporting to the State (no prescription fills to report). Leave blank"
. W !?5,"if the state does not require Zero Reporting."
. W !!?5,"Select one of the following:"
. W !
. S VER="" F S VER=$O(VERLST(VER)) Q:VER="" D
. . S HLPLN="",$E(HLPLN,11)=VER,$E(HLPLN,22)="ASAP Version "_$E(VER,1,$L(VER)-1)_$S(VERLST(VER)="FZ":"*",1:"")_" (Zero Report)"
. . I $$VERSIONLOCKED^PSOSPMU0($E(VER,1,$L(VER)-1)) S HLPLN=HLPLN_" << Locked >> " ;pso*7*772
. . W !,HLPLN
. W !
;
W !?5,"American Society for Automation in Pharmacy (ASAP) Version"
W !!?5,"Select one of the following:"
W !
S VER="" F S VER=$O(VERLST(VER)) Q:VER="" D
. N CLONE S CLONE=$G(VERLST(VER,"CLONE")) ; Standard Clone PSO*7*772
. S HLPLN="",$E(HLPLN,11)=VER,$E(HLPLN,22)="ASAP Version "_$E(VER,1,$L(VER)-1)_$S(VERLST(VER)="F":"*",$G(CLONE):"*",1:"") ; PSO*7*772
. I VERLST(VER)["FZ" S HLPLN="",$E(HLPLN,11)=VER,$E(HLPLN,22)="ASAP Version "_$E(VER,1,$L(VER)-1)_"*"_" (Zero Report)"
. I REGZERO["Z" S HLPLN=HLPLN_"*"
. I VERLST(VER)["SZ" S HLPLN=HLPLN_" (Zero Report)" ;adding Zero Report display
. I $$VERSIONLOCKED^PSOSPMU0($E(VER,1,$L(VER)-1)) S HLPLN=HLPLN_" << Locked >> " ;pso*7*772
. W !,HLPLN
W !
Q
;
RXFILL(RXIEN) ; Select Prescription Fill #
;Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
N RXFILL,DIR,I,Y,DIRUT,DTOUT,FILLARR,RTSFILL,RTSFLDT
S RXFILL=0,FILLARR(0)=""
K DIR S DIR("A")=" Fill",DIR("B")=0
S DIR(0)="S^0:Original ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,0),2)_") "_$$MWA(RXIEN,0)
F I=1:1 Q:'$D(^PSRX(RXIEN,1,I)) D
. S DIR(0)=DIR(0)_";"_I_":Refill "_I_" ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,I),2)_") "_$$MWA(RXIEN,I),FILLARR(I)=""
F I=1:1 Q:'$D(^PSRX(RXIEN,"P",I)) D
. S DIR(0)=DIR(0)_";P"_I_":Partial "_I_" ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,"P"_I),2)_") "_$$MWA(RXIEN,"P"_I),FILLARR("P"_I)=""
F I=1:1 Q:'$D(^PSRX(RXIEN,"RTS",I)) D
. S RTSFILL=$P(^PSRX(RXIEN,"RTS",I,0),"^",2) Q:RTSFILL="" I $D(FILLARR(RTSFILL)) Q
. S RTSFLDT=$P(^PSRX(RXIEN,"RTS",I,0),"^",3)
. S FILLARR(RTSFILL)=""
. S DIR(0)=DIR(0)_";"_RTSFILL_":"_$S(RTSFILL["P":"Partial "_$E(RTSFILL,2,9),1:"Refill "_RTSFILL)_" ("_$$FMTE^XLFDT(RTSFLDT,2)_") "_$$MWA(RXIEN,RTSFILL)
D ^DIR I $D(DIRUT)!$D(DTOUT) Q "^"
S RXFILL=$G(Y)
Q RXFILL
;
MWA(RXIEN,FILL) ; Returns the Rx delivering (WINDOW/MAIL/ADMIN IN CLINIC)
;Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
; (r) FILL - Rx Fill # (0:Original, 1:Refill #1,...,"P1":Partial #1, etc....)
I FILL["P" Q $$GET1^DIQ(52.2,$E(FILL,2,3)_","_RXIEN,.02)
I FILL Q:$$GET1^DIQ(52.1,FILL_","_RXIEN,23,"I") "ADMIN IN CLINIC" Q $$GET1^DIQ(52.1,FILL_","_RXIEN,2)
Q:$$GET1^DIQ(52,RXIEN,14,"I") "ADMIN IN CLINIC"
Q $$GET1^DIQ(52,RXIEN,11)
;
ASAPHELP(AVER,ASEG,AFLD) ; SPMP Help Text
; Retrieve ASAP text definition/description from SPMP ASAP RECORD DEFINITION file (#58.4)
; INPUT: AVER = ASAP Version
; ASEG = ASAP Segment
; AFLD = ASAP Field
;
N ASAP,LN
Q:$G(AVER)=""!($G(ASEG)="")!($G(AFLD)="")
D LOADASAP^PSOSPMU0(AVER,"B",.ASAP)
S LN=0 F S LN=$O(ASAP(ASEG,AFLD,"DES",LN)) Q:'LN D
.N TXT S TXT=$$UP^XLFSTR($G(ASAP(ASEG,AFLD,"DES",LN)))
.W ! I $E(TXT,1,3)=" 0" W $S(TXT["NEW":" N -",TXT["CHANGE":" R -",TXT["CANCEL":" V -",TXT]"VOID":" V",1:" ")
.W ASAP(ASEG,AFLD,"DES",LN)
Q
;
CUSTDEL(PSOASVER,SEGID,ELMPOS,ELMDATA,RETURN) ; Define elements for 'custom standard' ASAP version - PSO*7*772
; PSOASVER - ASAP Version to be udpated
; ELMDATA - Input string containing updated elements
; RETURN - Destination array containing updated elements
;
I $$CLONE^PSOSPML3(PSOASVER) D
. I $L($P(ELMDATA,"^",2)) S $P(RETURN(SEGID,ELMPOS),"^",2)=$P(ELMDATA,"^",2)
. I $L($P(ELMDATA,"^",3)) S $P(RETURN(SEGID,ELMPOS),"^",3)=$P(ELMDATA,"^",3)
. I $L($P(ELMDATA,"^",5)) S $P(RETURN(SEGID,ELMPOS),"^",5)=$P(ELMDATA,"^",5)
. I $D(ELMDATA("DES",1)) M RETURN(SEGID,ELMPOS,"DES")=ELMDATA("DES")
; PSO*7*772
Q
;
STDSEGCU(PSOASVER,STDASAP,CUSASAP,ALLASAP,CUSSEG) ; Customize Standard Segment - 772
; PSOASVER - ASAP Version
; STDASAP - Array of only Standard ASAP components related to PSOASVER
; CUSASAP - Array of only Custom ASAP components related to PSOASVER
; ALLASAP - Array of combined Standard and Custom components related to PSOASVER
; CUSSEG - Segment being worked on
;
N TMPASAP,SEGNMCUS,SEGNM,DONE,NEWSEG,OK,QUIT,SEG
S (Y,NEWSEG)=0
S $P(TMPASAP(CUSSEG),"^",1)=CUSSEG
; Segment Name
S SEGNM="",SEGNMCUS=$P($G(CUSASAP(CUSSEG)),"^",2) I $L(SEGNMCUS) S SEGNM=SEGNMCUS
I SEGNM="" S SEGNM=$P($G(STDASAP(CUSSEG)),"^",2)
S X=$$ASKFLD^PSOSPMA3("58.40011,.02",SEGNM) I X="^" Q
S $P(TMPASAP(CUSSEG),"^",2)=X
;
; Parent Segment
S DONE=0
N SEGPARCUS,SEGPAR S SEGPAR=""
S SEGPARCUS=$P($G(CUSASAP(CUSSEG)),"^",3) I $L(SEGPARCUS) S SEGPAR=SEGPARCUS
I SEGPAR="" S SEGPAR=$P($G(STDASAP(CUSSEG)),"^",3)
F S X=$$ASKFLD^PSOSPMA3("58.40011,.03",SEGPAR) Q:X="^"!(X="") D I DONE Q
. I X="@" S SEGPAR="",$P(TMPASAP(CUSSEG),"^",3)="" Q
. I '$D(ALLASAP(X)),$D(ALLASAP($$UP^XLFSTR(X))) S X=$$UP^XLFSTR(X)
. I '$D(ALLASAP(X))!$G(X) W !,"Parent Segment ID not found.",$C(7) Q
. I X=CUSSEG W !,"Parent Segment ID cannot be its own parent.",$C(7) Q
. W " ",$P(ALLASAP(X),"^",2)
. S $P(TMPASAP(CUSSEG),"^",3)=X,SEGPAR=X,DONE=1
I X="^" Q
;
; Segment Requirement
N SEGREQCUS,SEGREQ S SEGREQ=""
S SEGREQCUS=$P($G(CUSASAP(CUSSEG)),"^",4) I $L(SEGREQCUS) S SEGREQ=SEGREQCUS
I SEGREQ="" S SEGREQ=$P($G(STDASAP(CUSSEG)),"^",4)
S X=$$ASKFLD^PSOSPMA3("58.40011,.04",SEGREQ) I X="^" Q
S $P(TMPASAP(CUSSEG),"^",4)=X,SEGREQ=X
S DONE=0
;
; Segment Position
N SEGPOSCUS,SEGPOS S SEGPOS=""
S SEGPOSCUS=$P($G(ALLASAP(CUSSEG)),"^",5) I $L(SEGPOSCUS) S SEGPOS=SEGPOSCUS
I SEGPOS="" S SEGPOS=$P($G(ALLASAP(CUSSEG)),"^",5)
F S X=$$ASKFLD^PSOSPMA3("58.40011,.05",SEGPOS) Q:X="^" D I DONE Q
. S SEG="999",OK=1 F S SEG=$O(ALLASAP(SEG)) Q:SEG="" D I 'OK Q
. . I (SEG'=CUSSEG),($P(ALLASAP(SEG),"^",3)=$P($G(TMPASAP(CUSSEG)),"^",3)),($P(ALLASAP(SEG),"^",5)=X) D
. . . S OK=0 W !,"The Segment '",SEG,"' (",$P(ALLASAP(SEG),"^",2),") already occupies this position.",$C(7) Q
. I OK S $P(TMPASAP(CUSSEG),"^",5)=X,DONE=1
I X="^" Q
;
; Segment Level
S DONE=0
N SEGLEVCUS,SEGLEV S SEGLEV=""
S SEGLEVCUS=$P($G(ALLASAP(CUSSEG)),"^",6) I $L(SEGLEVCUS) S SEGLEV=SEGLEVCUS
I SEGLEV="" S SEGLEV=$P($G(CUSASAP(CUSSEG)),"^",6)
;
I SEGPAR'="",($P($G(CUSASAP(CUSSEG)),"^",6)=""),($P($G(ALLASAP(SEGPAR)),"^",6)>3) D
. S $P(TMPASAP(CUSSEG),"^",6)=$P($G(ALLASAP(SEGPAR)),"^",6)
F S X=$$ASKFLD^PSOSPMA3("58.40011,.06",SEGLEV) Q:X="^" D I DONE Q
. I (($P($G(CUSASAP(CUSSEG)),"^",3)="")&$P($G(ALLASAP(CUSSEG)),"^",3)=""),(X'=1),(X'=6) D Q
. . W !,"Orphan segments can only be located at the MAIN HEADER or MAIN TRAILER levels.",$C(7)
. S QUIT=0
. I SEGPAR'="" D I QUIT Q
. . I $P($G(ALLASAP(SEGPAR)),"^",6)>3,X'=$P($G(ALLASAP(SEGPAR)),"^",6) D S QUIT=1 Q
. . . W !,"Segment level must be the same as the parent's level (",$P($G(ALLASAP(SEGPAR)),"^",6),").",$C(7)
. . I X<$P($G(ALLASAP(SEGPAR)),"^",6) D S QUIT=1 Q
. . . W !,"Segment level cannot be lower than parent's level (",$P($G(ALLASAP(SEGPAR)),"^",6),").",$C(7)
. . I X>($P($G(ALLASAP(SEGPAR)),"^",6)+1) D S QUIT=1 Q
. . . W !,"Segment level cannot be more than 1 level above parent's level (",$P($G(ALLASAP(SEGPAR)),"^",6),").",$C(7)
. S $P(TMPASAP(CUSSEG),"^",6)=X,DONE=1
I X="^" Q
;
; Confirm
W ! S X=$$ASKFLD^PSOSPMA3("Y","YES","Save Custom Segment") I X'=1 Q
W ?40,"Saving..."
; If first time the Segment is being customized, copy; otherwise save
I '$D(CUSASAP(CUSSEG)) D
. S STDASAP(CUSSEG)=TMPASAP(CUSSEG)
. D COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSSEG)
E D
. D SAVESEG^PSOSPMU3(PSOASVER,CUSSEG,TMPASAP(CUSSEG),ALLASAP)
W "OK",$C(7)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOSPMU2 10007 printed Sep 23, 2025@20:11:39 Page 2
PSOSPMU2 ;BIRM/MFR - State Prescription Monitoring Program Utility #2 - Prompts ;10/07/15
+1 ;;7.0;OUTPATIENT PHARMACY;**451,625,772**;DEC 1997;Build 105
+2 ;
ASAPVER(DEFTYPE,REGZERO,DSPHLP,DEFAULT,REQUIRED,ALLOWDEL) ; Prompt for the ASAP Version
+1 ; Input: (r) DEFTYPE - ASAP Definition Type (S: Standard Only; C: Customized Only, F: Fully Customized Only,
+2 ; A: All. A combination is also allowed, e.g., "CF")
+3 ; (r) REGZERO - Regular or Zero Report or Both ASAP Definitions (R: Regular Only; Z: Zero Report Only;
+4 ; B: Both) ;adding new parameter for Zero Report
+5 ; (o) DSPHLP - Display Help before prompting? (1: YES / 0: NO)
+6 ; (o) DEFAULT - Default ASAP Version
+7 ; (o) REQUIRED - Is Answer Required? (1: YES / 0: NO)
+8 ; (o) ALLOWDEL - Allow delete? (accepts "@" as a valid input)
+9 ;Output: ASAPVER - ASAP Version, "^", "@" or ""
+10 NEW DIR,X,Y,DTOUT,DIRUT,VERLST
+11 ;
ASK1 ; Label used in case the prompt needs to be asked again
+1 ;Zero Report adding REGZERO
DO VERLIST^PSOSPMU0(DEFTYPE,REGZERO,.VERLST)
+2 ;K DIR S DIR(0)="FO^1:10",DIR("A")="ASAP VERSION" S:$G(DEFAULT)'="" DIR("B")=DEFAULT ;Zero Report
+3 IF REGZERO'["Z"
Begin DoDot:1
+4 KILL DIR
SET DIR(0)="FO^1:10"
SET DIR("A")="ASAP VERSION"
if $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 KILL DIR
SET DIR(0)="FO^1:10"
SET DIR("A")="ZERO REPORT ASAP VERSION"
if $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
End DoDot:1
+7 ;
+8 SET DIR("?")="^D HLP1^PSOSPMU2(.VERLST)"
IF $GET(DSPHLP)
DO HLP1^PSOSPMU2(.VERLST)
+9 DO ^DIR
+10 IF '$GET(REQUIRED)
IF X=""
QUIT X
+11 IF $GET(ALLOWDEL)
IF X="@"
QUIT X
+12 IF $GET(REQUIRED)
IF (X=""!(X="@"))
WRITE !,"This is a required response. Enter '^' to exit",$CHAR(7),!
GOTO ASK1
+13 IF $DATA(DIRUT)!$DATA(DTOUT)
QUIT "^"
+14 IF '$DATA(VERLST(X_" "))
WRITE ?40,"Invalid ASAP Version",$CHAR(7),!
GOTO ASK1
+15 QUIT X
+16 ;
HLP1(VERLST) ; Help Text for ASAP Version prompt and Zero Report ASAP Version prompt
+1 ;Input: (r) VERLST - Array containing a list ASAP versions
+2 NEW VER,HLPLN
+3 ;start Zero Report ASAP display
IF REGZERO["Z"
Begin DoDot:1
+4 WRITE !?5,"American Society for Automation in Pharmacy (ASAP) Version for Zero"
+5 WRITE !?5,"Reporting to the State (no prescription fills to report). Leave blank"
+6 WRITE !?5,"if the state does not require Zero Reporting."
+7 WRITE !!?5,"Select one of the following:"
+8 WRITE !
+9 SET VER=""
FOR
SET VER=$ORDER(VERLST(VER))
if VER=""
QUIT
Begin DoDot:2
+10 SET HLPLN=""
SET $EXTRACT(HLPLN,11)=VER
SET $EXTRACT(HLPLN,22)="ASAP Version "_$EXTRACT(VER,1,$LENGTH(VER)-1)_$SELECT(VERLST(VER)="FZ":"*",1:"")_" (Zero Report)"
+11 ;pso*7*772
IF $$VERSIONLOCKED^PSOSPMU0($EXTRACT(VER,1,$LENGTH(VER)-1))
SET HLPLN=HLPLN_" << Locked >> "
+12 WRITE !,HLPLN
End DoDot:2
+13 WRITE !
End DoDot:1
QUIT
+14 ;
+15 WRITE !?5,"American Society for Automation in Pharmacy (ASAP) Version"
+16 WRITE !!?5,"Select one of the following:"
+17 WRITE !
+18 SET VER=""
FOR
SET VER=$ORDER(VERLST(VER))
if VER=""
QUIT
Begin DoDot:1
+19 ; Standard Clone PSO*7*772
NEW CLONE
SET CLONE=$GET(VERLST(VER,"CLONE"))
+20 ; PSO*7*772
SET HLPLN=""
SET $EXTRACT(HLPLN,11)=VER
SET $EXTRACT(HLPLN,22)="ASAP Version "_$EXTRACT(VER,1,$LENGTH(VER)-1)_$SELECT(VERLST(VER)="F":"*",$GET(CLONE):"*",1:"")
+21 IF VERLST(VER)["FZ"
SET HLPLN=""
SET $EXTRACT(HLPLN,11)=VER
SET $EXTRACT(HLPLN,22)="ASAP Version "_$EXTRACT(VER,1,$LENGTH(VER)-1)_"*"_" (Zero Report)"
+22 IF REGZERO["Z"
SET HLPLN=HLPLN_"*"
+23 ;adding Zero Report display
IF VERLST(VER)["SZ"
SET HLPLN=HLPLN_" (Zero Report)"
+24 ;pso*7*772
IF $$VERSIONLOCKED^PSOSPMU0($EXTRACT(VER,1,$LENGTH(VER)-1))
SET HLPLN=HLPLN_" << Locked >> "
+25 WRITE !,HLPLN
End DoDot:1
+26 WRITE !
+27 QUIT
+28 ;
RXFILL(RXIEN) ; Select Prescription Fill #
+1 ;Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
+2 NEW RXFILL,DIR,I,Y,DIRUT,DTOUT,FILLARR,RTSFILL,RTSFLDT
+3 SET RXFILL=0
SET FILLARR(0)=""
+4 KILL DIR
SET DIR("A")=" Fill"
SET DIR("B")=0
+5 SET DIR(0)="S^0:Original ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,0),2)_") "_$$MWA(RXIEN,0)
+6 FOR I=1:1
if '$DATA(^PSRX(RXIEN,1,I))
QUIT
Begin DoDot:1
+7 SET DIR(0)=DIR(0)_";"_I_":Refill "_I_" ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,I),2)_") "_$$MWA(RXIEN,I)
SET FILLARR(I)=""
End DoDot:1
+8 FOR I=1:1
if '$DATA(^PSRX(RXIEN,"P",I))
QUIT
Begin DoDot:1
+9 SET DIR(0)=DIR(0)_";P"_I_":Partial "_I_" ("_$$FMTE^XLFDT($$RXFLDT^PSOBPSUT(RXIEN,"P"_I),2)_") "_$$MWA(RXIEN,"P"_I)
SET FILLARR("P"_I)=""
End DoDot:1
+10 FOR I=1:1
if '$DATA(^PSRX(RXIEN,"RTS",I))
QUIT
Begin DoDot:1
+11 SET RTSFILL=$PIECE(^PSRX(RXIEN,"RTS",I,0),"^",2)
if RTSFILL=""
QUIT
IF $DATA(FILLARR(RTSFILL))
QUIT
+12 SET RTSFLDT=$PIECE(^PSRX(RXIEN,"RTS",I,0),"^",3)
+13 SET FILLARR(RTSFILL)=""
+14 SET DIR(0)=DIR(0)_";"_RTSFILL_":"_$SELECT(RTSFILL["P":"Partial "_$EXTRACT(RTSFILL,2,9),1:"Refill "_RTSFILL)_" ("_$$FMTE^XLFDT(RTSFLDT,2)_") "_$$MWA(RXIEN,RTSFILL)
End DoDot:1
+15 DO ^DIR
IF $DATA(DIRUT)!$DATA(DTOUT)
QUIT "^"
+16 SET RXFILL=$GET(Y)
+17 QUIT RXFILL
+18 ;
MWA(RXIEN,FILL) ; Returns the Rx delivering (WINDOW/MAIL/ADMIN IN CLINIC)
+1 ;Input: (r) RXIEN - Pointer to the PRESCRIPTION file (#52)
+2 ; (r) FILL - Rx Fill # (0:Original, 1:Refill #1,...,"P1":Partial #1, etc....)
+3 IF FILL["P"
QUIT $$GET1^DIQ(52.2,$EXTRACT(FILL,2,3)_","_RXIEN,.02)
+4 IF FILL
if $$GET1^DIQ(52.1,FILL_","_RXIEN,23,"I")
QUIT "ADMIN IN CLINIC"
QUIT $$GET1^DIQ(52.1,FILL_","_RXIEN,2)
+5 if $$GET1^DIQ(52,RXIEN,14,"I")
QUIT "ADMIN IN CLINIC"
+6 QUIT $$GET1^DIQ(52,RXIEN,11)
+7 ;
ASAPHELP(AVER,ASEG,AFLD) ; SPMP Help Text
+1 ; Retrieve ASAP text definition/description from SPMP ASAP RECORD DEFINITION file (#58.4)
+2 ; INPUT: AVER = ASAP Version
+3 ; ASEG = ASAP Segment
+4 ; AFLD = ASAP Field
+5 ;
+6 NEW ASAP,LN
+7 if $GET(AVER)=""!($GET(ASEG)="")!($GET(AFLD)="")
QUIT
+8 DO LOADASAP^PSOSPMU0(AVER,"B",.ASAP)
+9 SET LN=0
FOR
SET LN=$ORDER(ASAP(ASEG,AFLD,"DES",LN))
if 'LN
QUIT
Begin DoDot:1
+10 NEW TXT
SET TXT=$$UP^XLFSTR($GET(ASAP(ASEG,AFLD,"DES",LN)))
+11 WRITE !
IF $EXTRACT(TXT,1,3)=" 0"
WRITE $SELECT(TXT["NEW":" N -",TXT["CHANGE":" R -",TXT["CANCEL":" V -",TXT]"VOID":" V",1:" ")
+12 WRITE ASAP(ASEG,AFLD,"DES",LN)
End DoDot:1
+13 QUIT
+14 ;
CUSTDEL(PSOASVER,SEGID,ELMPOS,ELMDATA,RETURN) ; Define elements for 'custom standard' ASAP version - PSO*7*772
+1 ; PSOASVER - ASAP Version to be udpated
+2 ; ELMDATA - Input string containing updated elements
+3 ; RETURN - Destination array containing updated elements
+4 ;
+5 IF $$CLONE^PSOSPML3(PSOASVER)
Begin DoDot:1
+6 IF $LENGTH($PIECE(ELMDATA,"^",2))
SET $PIECE(RETURN(SEGID,ELMPOS),"^",2)=$PIECE(ELMDATA,"^",2)
+7 IF $LENGTH($PIECE(ELMDATA,"^",3))
SET $PIECE(RETURN(SEGID,ELMPOS),"^",3)=$PIECE(ELMDATA,"^",3)
+8 IF $LENGTH($PIECE(ELMDATA,"^",5))
SET $PIECE(RETURN(SEGID,ELMPOS),"^",5)=$PIECE(ELMDATA,"^",5)
+9 IF $DATA(ELMDATA("DES",1))
MERGE RETURN(SEGID,ELMPOS,"DES")=ELMDATA("DES")
End DoDot:1
+10 ; PSO*7*772
+11 QUIT
+12 ;
STDSEGCU(PSOASVER,STDASAP,CUSASAP,ALLASAP,CUSSEG) ; Customize Standard Segment - 772
+1 ; PSOASVER - ASAP Version
+2 ; STDASAP - Array of only Standard ASAP components related to PSOASVER
+3 ; CUSASAP - Array of only Custom ASAP components related to PSOASVER
+4 ; ALLASAP - Array of combined Standard and Custom components related to PSOASVER
+5 ; CUSSEG - Segment being worked on
+6 ;
+7 NEW TMPASAP,SEGNMCUS,SEGNM,DONE,NEWSEG,OK,QUIT,SEG
+8 SET (Y,NEWSEG)=0
+9 SET $PIECE(TMPASAP(CUSSEG),"^",1)=CUSSEG
+10 ; Segment Name
+11 SET SEGNM=""
SET SEGNMCUS=$PIECE($GET(CUSASAP(CUSSEG)),"^",2)
IF $LENGTH(SEGNMCUS)
SET SEGNM=SEGNMCUS
+12 IF SEGNM=""
SET SEGNM=$PIECE($GET(STDASAP(CUSSEG)),"^",2)
+13 SET X=$$ASKFLD^PSOSPMA3("58.40011,.02",SEGNM)
IF X="^"
QUIT
+14 SET $PIECE(TMPASAP(CUSSEG),"^",2)=X
+15 ;
+16 ; Parent Segment
+17 SET DONE=0
+18 NEW SEGPARCUS,SEGPAR
SET SEGPAR=""
+19 SET SEGPARCUS=$PIECE($GET(CUSASAP(CUSSEG)),"^",3)
IF $LENGTH(SEGPARCUS)
SET SEGPAR=SEGPARCUS
+20 IF SEGPAR=""
SET SEGPAR=$PIECE($GET(STDASAP(CUSSEG)),"^",3)
+21 FOR
SET X=$$ASKFLD^PSOSPMA3("58.40011,.03",SEGPAR)
if X="^"!(X="")
QUIT
Begin DoDot:1
+22 IF X="@"
SET SEGPAR=""
SET $PIECE(TMPASAP(CUSSEG),"^",3)=""
QUIT
+23 IF '$DATA(ALLASAP(X))
IF $DATA(ALLASAP($$UP^XLFSTR(X)))
SET X=$$UP^XLFSTR(X)
+24 IF '$DATA(ALLASAP(X))!$GET(X)
WRITE !,"Parent Segment ID not found.",$CHAR(7)
QUIT
+25 IF X=CUSSEG
WRITE !,"Parent Segment ID cannot be its own parent.",$CHAR(7)
QUIT
+26 WRITE " ",$PIECE(ALLASAP(X),"^",2)
+27 SET $PIECE(TMPASAP(CUSSEG),"^",3)=X
SET SEGPAR=X
SET DONE=1
End DoDot:1
IF DONE
QUIT
+28 IF X="^"
QUIT
+29 ;
+30 ; Segment Requirement
+31 NEW SEGREQCUS,SEGREQ
SET SEGREQ=""
+32 SET SEGREQCUS=$PIECE($GET(CUSASAP(CUSSEG)),"^",4)
IF $LENGTH(SEGREQCUS)
SET SEGREQ=SEGREQCUS
+33 IF SEGREQ=""
SET SEGREQ=$PIECE($GET(STDASAP(CUSSEG)),"^",4)
+34 SET X=$$ASKFLD^PSOSPMA3("58.40011,.04",SEGREQ)
IF X="^"
QUIT
+35 SET $PIECE(TMPASAP(CUSSEG),"^",4)=X
SET SEGREQ=X
+36 SET DONE=0
+37 ;
+38 ; Segment Position
+39 NEW SEGPOSCUS,SEGPOS
SET SEGPOS=""
+40 SET SEGPOSCUS=$PIECE($GET(ALLASAP(CUSSEG)),"^",5)
IF $LENGTH(SEGPOSCUS)
SET SEGPOS=SEGPOSCUS
+41 IF SEGPOS=""
SET SEGPOS=$PIECE($GET(ALLASAP(CUSSEG)),"^",5)
+42 FOR
SET X=$$ASKFLD^PSOSPMA3("58.40011,.05",SEGPOS)
if X="^"
QUIT
Begin DoDot:1
+43 SET SEG="999"
SET OK=1
FOR
SET SEG=$ORDER(ALLASAP(SEG))
if SEG=""
QUIT
Begin DoDot:2
+44 IF (SEG'=CUSSEG)
IF ($PIECE(ALLASAP(SEG),"^",3)=$PIECE($GET(TMPASAP(CUSSEG)),"^",3))
IF ($PIECE(ALLASAP(SEG),"^",5)=X)
Begin DoDot:3
+45 SET OK=0
WRITE !,"The Segment '",SEG,"' (",$PIECE(ALLASAP(SEG),"^",2),") already occupies this position.",$CHAR(7)
QUIT
End DoDot:3
End DoDot:2
IF 'OK
QUIT
+46 IF OK
SET $PIECE(TMPASAP(CUSSEG),"^",5)=X
SET DONE=1
End DoDot:1
IF DONE
QUIT
+47 IF X="^"
QUIT
+48 ;
+49 ; Segment Level
+50 SET DONE=0
+51 NEW SEGLEVCUS,SEGLEV
SET SEGLEV=""
+52 SET SEGLEVCUS=$PIECE($GET(ALLASAP(CUSSEG)),"^",6)
IF $LENGTH(SEGLEVCUS)
SET SEGLEV=SEGLEVCUS
+53 IF SEGLEV=""
SET SEGLEV=$PIECE($GET(CUSASAP(CUSSEG)),"^",6)
+54 ;
+55 IF SEGPAR'=""
IF ($PIECE($GET(CUSASAP(CUSSEG)),"^",6)="")
IF ($PIECE($GET(ALLASAP(SEGPAR)),"^",6)>3)
Begin DoDot:1
+56 SET $PIECE(TMPASAP(CUSSEG),"^",6)=$PIECE($GET(ALLASAP(SEGPAR)),"^",6)
End DoDot:1
+57 FOR
SET X=$$ASKFLD^PSOSPMA3("58.40011,.06",SEGLEV)
if X="^"
QUIT
Begin DoDot:1
+58 IF (($PIECE($GET(CUSASAP(CUSSEG)),"^",3)="")&$PIECE($GET(ALLASAP(CUSSEG)),"^",3)="")
IF (X'=1)
IF (X'=6)
Begin DoDot:2
+59 WRITE !,"Orphan segments can only be located at the MAIN HEADER or MAIN TRAILER levels.",$CHAR(7)
End DoDot:2
QUIT
+60 SET QUIT=0
+61 IF SEGPAR'=""
Begin DoDot:2
+62 IF $PIECE($GET(ALLASAP(SEGPAR)),"^",6)>3
IF X'=$PIECE($GET(ALLASAP(SEGPAR)),"^",6)
Begin DoDot:3
+63 WRITE !,"Segment level must be the same as the parent's level (",$PIECE($GET(ALLASAP(SEGPAR)),"^",6),").",$CHAR(7)
End DoDot:3
SET QUIT=1
QUIT
+64 IF X<$PIECE($GET(ALLASAP(SEGPAR)),"^",6)
Begin DoDot:3
+65 WRITE !,"Segment level cannot be lower than parent's level (",$PIECE($GET(ALLASAP(SEGPAR)),"^",6),").",$CHAR(7)
End DoDot:3
SET QUIT=1
QUIT
+66 IF X>($PIECE($GET(ALLASAP(SEGPAR)),"^",6)+1)
Begin DoDot:3
+67 WRITE !,"Segment level cannot be more than 1 level above parent's level (",$PIECE($GET(ALLASAP(SEGPAR)),"^",6),").",$CHAR(7)
End DoDot:3
SET QUIT=1
QUIT
End DoDot:2
IF QUIT
QUIT
+68 SET $PIECE(TMPASAP(CUSSEG),"^",6)=X
SET DONE=1
End DoDot:1
IF DONE
QUIT
+69 IF X="^"
QUIT
+70 ;
+71 ; Confirm
+72 WRITE !
SET X=$$ASKFLD^PSOSPMA3("Y","YES","Save Custom Segment")
IF X'=1
QUIT
+73 WRITE ?40,"Saving..."
+74 ; If first time the Segment is being customized, copy; otherwise save
+75 IF '$DATA(CUSASAP(CUSSEG))
Begin DoDot:1
+76 SET STDASAP(CUSSEG)=TMPASAP(CUSSEG)
+77 DO COPYSEG^PSOSPMU3(PSOASVER,.STDASAP,PSOASVER,CUSSEG)
End DoDot:1
+78 IF '$TEST
Begin DoDot:1
+79 DO SAVESEG^PSOSPMU3(PSOASVER,CUSSEG,TMPASAP(CUSSEG),ALLASAP)
End DoDot:1
+80 WRITE "OK",$CHAR(7)
+81 QUIT
