RAPSAPI ;HOIFO/SWM-calling Pharmacy APIs ; 20 Apr 2011 6:59 PM
;;5.0;Radiology/Nuclear Medicine;**65,1003**;Nov 01, 2010;Build 3
;
;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
Q
EN1(RAX,RAN) ; call data^pss50 to get external values to some fields
;IHS/BJI/DAY - Patch 1003 - Temporary Change for patch 1003
;This can be removed when the full PSS patch is installed
S X=$$GET1^DIQ(50,+RAX,RAN)
Q X
;End Patch
; 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
Q
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")
Q
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
Q
SHO W !?3,RA
I $Y>(IOSL+RALINE-3) D PAUSE S RALINE=$Y
Q
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=""
Q
PAUSE ;
K DIR S DIR(0)="E" D ^DIR K DIR S RAQUIT=$S(Y:0,1:1)
Q
; 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)
RAPSAPI ;HOIFO/SWM-calling Pharmacy APIs ; 20 Apr 2011 6:59 PM
+1 ;;5.0;Radiology/Nuclear Medicine;**65,1003**;Nov 01, 2010;Build 3
+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 ;IHS/BJI/DAY - Patch 1003 - Temporary Change for patch 1003
+2 ;This can be removed when the full PSS patch is installed
+3 SET X=$$GET1^DIQ(50,+RAX,RAN)
+4 QUIT X
+5 ;End Patch
+6 ; input RAX is ien to file 50
+7 ; input RAN is field number of file 50 to display
+8 NEW RAY,X,SCR
+9 IF RAX=""
SET RAX=+RAX
+10 KILL ^TMP($JOB,"RAPSS50")
+11 DO DATA^PSS50(RAX,"","","","","RAPSS50")
+12 SET RAY=$GET(^TMP($JOB,"RAPSS50",RAX,RAN))
+13 KILL ^TMP($JOB,"RAPSS50")
+14 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)
