Routine: RAPSAPI

RAPSAPI ;HOIFO/SWM-calling Pharmacy APIs ;8/29/05  08:12

 ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8

 ;DBIA: 4533  DATA^PSS50 returns external value of field from file #50

 ;DBIA: 4533  ZERO^PSS50 returns B crossreference of file #50

 ;DBIA: 4551  DO^PSSDI puts header info from file #50 into local vars

 ;DBIA: 4551 ($$FNAME^PSSDI) returns field value from file #50

 ;DBIA: 4551  DIC^PSSDI  looks up & screens records from file #50

 ;DBIA: 2055  reference to ROOT^DILFD

EN1(RAX,RAN) ; call data^pss50 to get external values to some fields

 ; input RAX is ien to file 50

 ; input RAN is field number of file 50 to display

 N RAY,X,SCR

 S:RAX="" RAX=+RAX

 K ^TMP($J,"RAPSS50")

 D DATA^PSS50(RAX,"","","","","RAPSS50")

 S RAY=$G(^TMP($J,"RAPSS50",RAX,RAN))

 K ^TMP($J,"RAPSS50")

 Q RAY

EN2(RADIC,RAUTIL) ; adapted from EN1^RASELCT

 ; called from selradio+11^RANMUTL1

 ;REQUIRES:

 ;  RADIC      = FILE NUMBER OR GLOBAL ROOT

 ;  RADIC(0)   = DIC(0) STRING

 ;  RAUTIL     = NODE TO STORE DATA UNDER IN ^TMP($J,RAUTIL,

 ;  RAVACL()   = ARRAY OF VA CLASS DRUGS TO INCLUDE

 ;  RAVACL("R") = INDICATE RADIOPHARMS ONLY

 ;OPTIONAL:

 ;  RADIC("A") = DIC("A") STRING

 ;  RADIC("S") is not accepted by DIC^PSSDI

 ;RETURNS:

 ;  1) RAQUIT     = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)

 ;  2) ^TMP($J,RAUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""

 S RAQUIT=0

 I ($G(RADIC)="")!($G(RADIC(0))="")!($G(RAUTIL)="") S RAQUIT=1 G EXIT

 N DIC,PSSDIY,X,Y

 D K S DIC=RADIC I DIC S (RADIC,DIC)=$$ROOT^DILFD(DIC) I DIC="" S RAQUIT=1 G EXIT

 S DIC(0)=RADIC(0),DIC(0)=$TR(DIC(0),"AL") S:DIC(0)'["Z" DIC(0)=DIC(0)_"Z" S RADIC(0)=DIC(0)

 D DO^PSSDI(50,"RA",.RADIC)

 I PSSDIY=-1 S RAQUIT=1 G EXIT  ; -1 if file access invalid

 S RAFNAME=$P(DO,"^"),RAFLD01=$$FNAME^PSSDI(.01,50) K DO

 S RANUM=1 K ^TMP($J,RAUTIL) D HOME^%ZIS

1 ;

 W !!,$S(RANUM>1:"Another one (Select/De-Select): ",1:RADIC("A"))

 R X:DTIME S:('$T)!($E(X)="^") RAQUIT=1 G:RAQUIT EXIT G:X="" EXIT S RADSEL=$S(X?1"-"1.E:1,1:0) S:RADSEL X=$E(X,2,$L(X))

 I $L(X),(X["*") D SOME G 1

 ;removed checking for ALL because user answered "N" to all in selradio^ranmutl1

 D HELP:$E(X)="?"

 ; cannot call old SEL() to prevent reselection since can't use DIC("S")

 ; but no problem as same drug is stored only once in ^TMP

 ; null 6th piece skip check drug inactive dt -- want select old drugs

 D SETVACL^RAPSAPI2("R")

 D DIC^PSSDI(50,"RA",.RADIC,.X,"","","",.RAVACL)

 G:+Y'>0 1

 ; no rafld

 I 'RADSEL,'$D(^TMP($J,RAUTIL,$E($P(Y,U,2),1,63),+Y)) S ^(+Y)="",RANUM=RANUM+1

 I RADSEL,$D(^TMP($J,RAUTIL,$E($P(Y,U,2),1,63),+Y)) K ^(+Y) S RANUM=RANUM-$S(RANUM>0:1,1:0)

G 1

EXIT ;

  S RAQUIT=$S(RAQUIT:1,$O(^TMP($J,RAUTIL,""))="":1,1:0) K RADIC,RAUTIL

K K %,%X,%Y,%Z,C,D0,DA,DIC,DIK,DIR,DO,RA,RAALL,RACASE,RAD0,RADSEL,RAFLD01

 K RAFNAME,RAFNUM,RAFSCR,RALINE,RANUM,RAVALUE,X,Y,RAVACL

SOME ; SG 4/12/07

 N RA50I,RADIC0,RAENTRY,RAXN,NAME

 I $E(X,$L(X))'="*" W " ??",$C(7) Q

 I $L(X)=1 W "  ?? Enter at least 1 character before the ""*"".",$C(7) Q

 S RADIC0=RADIC(0),RADIC(0)="" ; no terminal output

 S RAENTRY=$E(X,1,$L(X)-1)

 D ZERO^PSS50(,RAENTRY,,,,"RAPSS50")

 S RAXN=""

 F  S RAXN=$O(^TMP($J,"RAPSS50","B",RAXN)) Q:RAXN=""  D

 . S RA50I=0

 . F  S RA50I=$O(^TMP($J,"RAPSS50","B",RAXN,RA50I))  Q:RA50I'>0  D

 . . ; screen data

 . . D SETVACL^RAPSAPI2("R")

 . . D DIC^PSSDI(50,"RA",.RADIC,"`"_RA50I,,,,.RAVACL)

 . . Q:+Y'>0

 . . S NAME=$E($P(Y,U,2),1,63)

 . . ; add

 . . I 'RADSEL D:'$D(^TMP($J,RAUTIL,NAME,+Y))  Q

 . . . S ^TMP($J,RAUTIL,NAME,+Y)="",RANUM=RANUM+1

 . . ; remove

 . . I $D(^TMP($J,RAUTIL,NAME,+Y)) K ^(+Y) S:RANUM>0 RANUM=RANUM-1

 S RADIC(0)=RADIC0

 K ^TMP($J,"RAPSS50")

HELP ;

 N X S RA="Select a "_RAFNAME_" "_RAFLD01_" from the displayed list." D WRAP

 W !?5,"To deselect a ",RAFLD01," type a minus sign (-)",!?5,"in front of it, e.g.,  -",RAFLD01,"."

 W !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"

 W !?5,"enter ",RAFLD01,"* to select all entries that begin"

 W !?5,"with the text '",RAFLD01,"'.  Wildcard selection is"

 W !?5,"case sensitive."

 G:$O(^TMP($J,RAUTIL,""))="" HLP

SHOW S RALINE=$Y,RA="" W !!,"You have already selected:"

 F  S RA=$O(^TMP($J,RAUTIL,RA)) Q:RA=""!RAQUIT  F RAD0=0:0 S RAD0=$O(^TMP($J,RAUTIL,RA,RAD0)) Q:RAD0'>0!RAQUIT  D SHO

HLP W ! S RAQUIT=0

SHO W !?3,RA

 I $Y>(IOSL+RALINE-3) D PAUSE S RALINE=$Y

WRAP ;

 W ! F  S Y=$L($E(RA,1,IOM-20)," ") W !?5,$P(RA," ",1,Y) S RA=$P(RA," ",Y+1,999) Q:RA=""

PAUSE ;

 K DIR S DIR(0)="E" D ^DIR K DIR S RAQUIT=$S(Y:0,1:1)

 ; exclude SETDIC and SEL(Y) sections from routine RASELCT

EN5() ;display identifier from file 71.9, field 5 radiopharm

 ; ^(0) is ^RAMIS(71.9,-,0)

 Q $$EN1(+$P(^(0),U,5),.01)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPSAPI   4777     printed  Mar 13, 2025@21:43:40                                                                                                                                                                                                     Page 2

RAPSAPI   ;HOIFO/SWM-calling Pharmacy APIs ;8/29/05  08:12

 +1       ;;5.0;Radiology/Nuclear Medicine;**65**;Mar 16, 1998;Build 8

 +2       ;

 +3       ;DBIA: 4533  DATA^PSS50 returns external value of field from file #50

 +4       ;DBIA: 4533  ZERO^PSS50 returns B crossreference of file #50

 +5       ;DBIA: 4551  DO^PSSDI puts header info from file #50 into local vars

 +6       ;DBIA: 4551 ($$FNAME^PSSDI) returns field value from file #50

 +7       ;DBIA: 4551  DIC^PSSDI  looks up & screens records from file #50

 +8       ;DBIA: 2055  reference to ROOT^DILFD

 +9        QUIT

EN1(RAX,RAN) ; call data^pss50 to get external values to some fields

 +1       ; input RAX is ien to file 50

 +2       ; input RAN is field number of file 50 to display

 +3        NEW RAY,X,SCR

 +4        if RAX=""

               SET RAX=+RAX

 +5        KILL ^TMP($JOB,"RAPSS50")

 +6        DO DATA^PSS50(RAX,"","","","","RAPSS50")

 +7        SET RAY=$GET(^TMP($JOB,"RAPSS50",RAX,RAN))

 +8        KILL ^TMP($JOB,"RAPSS50")

 +9        QUIT RAY

EN2(RADIC,RAUTIL) ; adapted from EN1^RASELCT

 +1       ; called from selradio+11^RANMUTL1

 +2       ;REQUIRES:

 +3       ;  RADIC      = FILE NUMBER OR GLOBAL ROOT

 +4       ;  RADIC(0)   = DIC(0) STRING

 +5       ;  RAUTIL     = NODE TO STORE DATA UNDER IN ^TMP($J,RAUTIL,

 +6       ;  RAVACL()   = ARRAY OF VA CLASS DRUGS TO INCLUDE

 +7       ;  RAVACL("R") = INDICATE RADIOPHARMS ONLY

 +8       ;OPTIONAL:

 +9       ;  RADIC("A") = DIC("A") STRING

 +10      ;  RADIC("S") is not accepted by DIC^PSSDI

 +11      ;

 +12      ;RETURNS:

 +13      ;  1) RAQUIT     = $S(UP_ARROW_OUT:1 , NOTHING_SELECTED:1 , 1:0)

 +14      ;  2) ^TMP($J,RAUTIL,EXTERNAL_.01_FIELD_DATA,IEN) = ""

 +15      ;

 +16       SET RAQUIT=0

 +17       IF ($GET(RADIC)="")!($GET(RADIC(0))="")!($GET(RAUTIL)="")

               SET RAQUIT=1

               GOTO EXIT

 +18       NEW DIC,PSSDIY,X,Y

 +19       DO K

           SET DIC=RADIC

           IF DIC

               SET (RADIC,DIC)=$$ROOT^DILFD(DIC)

               IF DIC=""

                   SET RAQUIT=1

                   GOTO EXIT

 +20       SET DIC(0)=RADIC(0)

           SET DIC(0)=$TRANSLATE(DIC(0),"AL")

           if DIC(0)'["Z"

               SET DIC(0)=DIC(0)_"Z"

           SET RADIC(0)=DIC(0)

 +21       DO DO^PSSDI(50,"RA",.RADIC)

 +22      ; -1 if file access invalid

           IF PSSDIY=-1

               SET RAQUIT=1

               GOTO EXIT

 +23       SET RAFNAME=$PIECE(DO,"^")

           SET RAFLD01=$$FNAME^PSSDI(.01,50)

           KILL DO

 +24       SET RANUM=1

           KILL ^TMP($JOB,RAUTIL)

           DO HOME^%ZIS

1         ;

 +1        WRITE !!,$SELECT(RANUM>1:"Another one (Select/De-Select): ",1:RADIC("A"))

 +2        READ X:DTIME

           if ('$TEST)!($EXTRACT(X)="^")

               SET RAQUIT=1

           if RAQUIT

               GOTO EXIT

           if X=""

               GOTO EXIT

           SET RADSEL=$SELECT(X?1"-"1.E:1,1:0)

           if RADSEL

               SET X=$EXTRACT(X,2,$LENGTH(X))

 +3        IF $LENGTH(X)

               IF (X["*")

                   DO SOME

                   GOTO 1

 +4       ;removed checking for ALL because user answered "N" to all in selradio^ranmutl1

 +5        if $EXTRACT(X)="?"

               DO HELP

 +6       ; cannot call old SEL() to prevent reselection since can't use DIC("S")

 +7       ; but no problem as same drug is stored only once in ^TMP

 +8       ;

 +9       ; null 6th piece skip check drug inactive dt -- want select old drugs

 +10       DO SETVACL^RAPSAPI2("R")

 +11       DO DIC^PSSDI(50,"RA",.RADIC,.X,"","","",.RAVACL)

 +12       if +Y'>0

               GOTO 1

 +13      ; no rafld

 +14       IF 'RADSEL

               IF '$DATA(^TMP($JOB,RAUTIL,$EXTRACT($PIECE(Y,U,2),1,63),+Y))

                   SET ^(+Y)=""

                   SET RANUM=RANUM+1

 +15       IF RADSEL

               IF $DATA(^TMP($JOB,RAUTIL,$EXTRACT($PIECE(Y,U,2),1,63),+Y))

                   KILL ^(+Y)

                   SET RANUM=RANUM-$SELECT(RANUM>0:1,1:0)

 +16       GOTO 1

EXIT      ;

 +1        SET RAQUIT=$SELECT(RAQUIT:1,$ORDER(^TMP($JOB,RAUTIL,""))="":1,1:0)

           KILL RADIC,RAUTIL

K          KILL %,%X,%Y,%Z,C,D0,DA,DIC,DIK,DIR,DO,RA,RAALL,RACASE,RAD0,RADSEL,RAFLD01

 +1        KILL RAFNAME,RAFNUM,RAFSCR,RALINE,RANUM,RAVALUE,X,Y,RAVACL

 +2        QUIT

SOME      ; SG 4/12/07

 +1        NEW RA50I,RADIC0,RAENTRY,RAXN,NAME

 +2        IF $EXTRACT(X,$LENGTH(X))'="*"

               WRITE " ??",$CHAR(7)

               QUIT

 +3        IF $LENGTH(X)=1

               WRITE "  ?? Enter at least 1 character before the ""*"".",$CHAR(7)

               QUIT

 +4       ; no terminal output

           SET RADIC0=RADIC(0)

           SET RADIC(0)=""

 +5        SET RAENTRY=$EXTRACT(X,1,$LENGTH(X)-1)

 +6        DO ZERO^PSS50(,RAENTRY,,,,"RAPSS50")

 +7        SET RAXN=""

 +8        FOR

               SET RAXN=$ORDER(^TMP($JOB,"RAPSS50","B",RAXN))

               if RAXN=""

                   QUIT

               Begin DoDot:1

 +9                SET RA50I=0

 +10               FOR

                       SET RA50I=$ORDER(^TMP($JOB,"RAPSS50","B",RAXN,RA50I))

                       if RA50I'>0

                           QUIT

                       Begin DoDot:2

 +11      ; screen data

 +12                       DO SETVACL^RAPSAPI2("R")

 +13                       DO DIC^PSSDI(50,"RA",.RADIC,"`"_RA50I,,,,.RAVACL)

 +14                       if +Y'>0

                               QUIT

 +15                       SET NAME=$EXTRACT($PIECE(Y,U,2),1,63)

 +16      ; add

 +17                       IF 'RADSEL

                               if '$DATA(^TMP($JOB,RAUTIL,NAME,+Y))

                                   Begin DoDot:3

 +18                                   SET ^TMP($JOB,RAUTIL,NAME,+Y)=""

                                       SET RANUM=RANUM+1

                                   End DoDot:3

                               QUIT

 +19      ; remove

 +20                       IF $DATA(^TMP($JOB,RAUTIL,NAME,+Y))

                               KILL ^(+Y)

                               if RANUM>0

                                   SET RANUM=RANUM-1

                       End DoDot:2

               End DoDot:1

 +21       SET RADIC(0)=RADIC0

 +22       KILL ^TMP($JOB,"RAPSS50")

 +23       QUIT

HELP      ;

 +1        NEW X

           SET RA="Select a "_RAFNAME_" "_RAFLD01_" from the displayed list."

           DO WRAP

 +2        WRITE !?5,"To deselect a ",RAFLD01," type a minus sign (-)",!?5,"in front of it, e.g.,  -",RAFLD01,"."

 +3        WRITE !?5,"Use an asterisk (*) to do a wildcard selection, e.g.,"

 +4        WRITE !?5,"enter ",RAFLD01,"* to select all entries that begin"

 +5        WRITE !?5,"with the text '",RAFLD01,"'.  Wildcard selection is"

 +6        WRITE !?5,"case sensitive."

 +7        if $ORDER(^TMP($JOB,RAUTIL,""))=""

               GOTO HLP

SHOW       SET RALINE=$Y

           SET RA=""

           WRITE !!,"You have already selected:"

 +1        FOR

               SET RA=$ORDER(^TMP($JOB,RAUTIL,RA))

               if RA=""!RAQUIT

                   QUIT

               FOR RAD0=0:0

                   SET RAD0=$ORDER(^TMP($JOB,RAUTIL,RA,RAD0))

                   if RAD0'>0!RAQUIT

                       QUIT

                   DO SHO

HLP        WRITE !

           SET RAQUIT=0

 +1        QUIT

SHO        WRITE !?3,RA

 +1        IF $Y>(IOSL+RALINE-3)

               DO PAUSE

               SET RALINE=$Y

 +2        QUIT

WRAP      ;

 +1        WRITE !

FOR

               SET Y=$LENGTH($EXTRACT(RA,1,IOM-20)," ")

               WRITE !?5,$PIECE(RA," ",1,Y)

               SET RA=$PIECE(RA," ",Y+1,999)

               if RA=""

                   QUIT

 +2        QUIT

PAUSE     ;

 +1        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           SET RAQUIT=$SELECT(Y:0,1:1)

 +2        QUIT

 +3       ; exclude SETDIC and SEL(Y) sections from routine RASELCT

 +4       ;

EN5()     ;display identifier from file 71.9, field 5 radiopharm

 +1       ; ^(0) is ^RAMIS(71.9,-,0)

 +2        QUIT $$EN1(+$PIECE(^(0),U,5),.01)

RAPSAPI.m