SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST; APRIL 18, 2007@11:55am
;;3.0;Surgery;**58,119,162,214**;24 Jun 93;Build 3
;
ENTER ; enter a patient on the waiting list
S SRSOUT=0 W @IOF K DIC S DIC(0)="QEAMZL",(DIC,DLAYGO)=133.8,DIC("A")=" Select Surgical Specialty: " D ^DIC K DIC,DLAYGO G:Y<0 END S SRSS=+Y,SRSS1=+Y(0)
S SRSSNM=$P(^SRO(137.45,SRSS1,0),"^")
PAT W ! S DIC=2,DIC(0)="QEAMZ",DIC("A")=" Select Patient: " D ^DIC K DIC I Y<0 W !!,"No action taken." G END
S DFN=+Y,SRNM=$P(Y(0),"^") I $D(^DPT(DFN,.35)),$P(^(.35),"^")'="" S Y=$E($P(^(.35),"^"),1,7) D D^DIQ W !!,"The records show that "_SRNM_" died on "_Y_".",! G PAT
I $O(^SRO(133.8,"AP",DFN,SRSS,0)) D CHK G:"Yy"'[ECYN END
OP W ! K DIR S DIR("A")=" Select Operative Procedure",DIR(0)="133.801,1" D ^DIR I $D(DTOUT)!$D(DUOUT) W !!,"No action taken." G END
S SROPER=Y
W ! D NOW^%DTC S SRSDT=%
K DD,DO,DIC,DR,DA S DIC(0)="L",DIC="^SRO(133.8,SRSS,1,",DA(1)=SRSS,X=DFN D FILE^DICN I +Y S SROFN=+Y
K DA,DIE,DR S DA=SRSS,DIE=133.8,DR="1///"_SRNM,DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T",DR(3,133.8013)=".01T;1T;2T;3T;4T;5T" D ^DIE K DIE,DR
D WL^SROPCE1 I SRSOUT G DEL
W @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
END D PRESS,^SRSKILL W @IOF
Q
PRESS W ! K DIR S DIR("A")="Press RETURN to continue ",DIR(0)="FOA" D ^DIR K DIR
Q
DEL S DA(1)=SRSS,DA=SROFN,DIK="^SRO(133.8,"_DA(1)_",1," D ^DIK
W @IOF,!,"Classification information is incomplete. No action taken." G END
Q
HELP W !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_". If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option."
W !!,"Press RETURN to continue " R X:DTIME
Q
CHK ; check for existing entries for a patient
W @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
S SROFN=0 F S SROFN=$O(^SRO(133.8,"AP",DFN,SRSS,SROFN)) Q:'SROFN D LIST
W !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ? YES// " R ECYN:DTIME I '$T!(ECYN["^") S ECYN="N" Q
S ECYN=$E(ECYN) S:"y"[ECYN ECYN="Y"
I "YNn"'[ECYN D HELP G CHK
Q
LIST ; list existing procedures for specialty selected
S SROPER=$P(^SRO(133.8,SRSS,1,SROFN,0),"^",2),SRDT=$P(^(0),"^",3),SROPDT=$P(^(0),"^",5),Y=SRDT D D^DIQ S SRDT=$E(Y,1,12) I SROPDT S Y=SROPDT D D^DIQ S SROPDT=$E(Y,1,12)
K SROP,MM,MMM S:$L(SROPER)<36 SROP(1)=SROPER I $L(SROPER)>35 S SROPER=SROPER_" " S SROPER=SROPER_" " F M=1:1 D LOOP Q:MMM=""
W !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
I $D(SROP(2)) W !,?3,SROP(2)
W !
Q
LOOP ; break procedure if greater than 36 characters
S SROP(M)="" F LOOP=1:1 S MM=$P(SROPER," "),MMM=$P(SROPER," ",2,200) Q:MMM="" Q:$L(SROP(M))+$L(MM)'<36 S SROP(M)=SROP(M)_MM_" ",SROPER=MMM
Q
REFPHY ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
N SRCONT,Y,SRDEMO
S SRCONT=""
PRMPT R !,"Is this a VA Physician from this facility? (Y/N): <Y> ",SRCONT:DTIME I '$T Q
I SRCONT["?" D G PRMPT
.W !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
S:SRCONT="" SRCONT="Y"
I SRCONT="^" S X="" Q
Q:(SRCONT'["Y")&(SRCONT'["y")
; Store FileMan variables and arrays
M SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
S DIC="^VA(200,",DIC(0)="E",DIC("B")=X
D ^DIC K DIC("B") ;SR*3*214 - KILL the default
; Restore FileMan's variables and arrays
M DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
K SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
Q:Y="-1" ; Quit if no record was selected from the NEW PERSON file
S SRNPREC=$P(Y,U,1)_"," ;The record number of the NEW PERSON file
; Retrieve demographic data from the NEW PERSON file.
D GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
S X=SRDEMO(200,SRNPREC,".01") ;Name
S SRDEMO(1)=SRDEMO(200,SRNPREC,".111") ;Address
S:$L(SRDEMO(200,SRNPREC,".112"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112") ;Concatenate Address 2 to single address
S:$L(SRDEMO(200,SRNPREC,".113"))>0 SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113") ;Concatenate Address 3 to single address
S SRDEMO(1)=$E(SRDEMO(1),1,75)
S SRDEMO(2)=SRDEMO(200,SRNPREC,".114") ;City
S SRDEMO(3)=SRDEMO(200,SRNPREC,".115") ;State
S SRDEMO(4)=SRDEMO(200,SRNPREC,".116") ;Zip
S SRDEMO(5)=SRDEMO(200,SRNPREC,".132") ;Office Phone
; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
; all fields except STATE will ignore input transform (SR*3.0*162)
S DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$P(Y,U,1)
S DIC(0)="Z" ;Tells FileMan to file the data without any more user input
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSROWL 5270 printed Dec 13, 2024@02:46:40 Page 2
SROWL ;B'HAM ISC/MAM - ENTER PATIENT ON WAITING LIST; APRIL 18, 2007@11:55am
+1 ;;3.0;Surgery;**58,119,162,214**;24 Jun 93;Build 3
+2 ;
ENTER ; enter a patient on the waiting list
+1 SET SRSOUT=0
WRITE @IOF
KILL DIC
SET DIC(0)="QEAMZL"
SET (DIC,DLAYGO)=133.8
SET DIC("A")=" Select Surgical Specialty: "
DO ^DIC
KILL DIC,DLAYGO
if Y<0
GOTO END
SET SRSS=+Y
SET SRSS1=+Y(0)
+2 SET SRSSNM=$PIECE(^SRO(137.45,SRSS1,0),"^")
PAT WRITE !
SET DIC=2
SET DIC(0)="QEAMZ"
SET DIC("A")=" Select Patient: "
DO ^DIC
KILL DIC
IF Y<0
WRITE !!,"No action taken."
GOTO END
+1 SET DFN=+Y
SET SRNM=$PIECE(Y(0),"^")
IF $DATA(^DPT(DFN,.35))
IF $PIECE(^(.35),"^")'=""
SET Y=$EXTRACT($PIECE(^(.35),"^"),1,7)
DO D^DIQ
WRITE !!,"The records show that "_SRNM_" died on "_Y_".",!
GOTO PAT
+2 IF $ORDER(^SRO(133.8,"AP",DFN,SRSS,0))
DO CHK
if "Yy"'[ECYN
GOTO END
OP WRITE !
KILL DIR
SET DIR("A")=" Select Operative Procedure"
SET DIR(0)="133.801,1"
DO ^DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
WRITE !!,"No action taken."
GOTO END
+1 SET SROPER=Y
+2 WRITE !
DO NOW^%DTC
SET SRSDT=%
+3 KILL DD,DO,DIC,DR,DA
SET DIC(0)="L"
SET DIC="^SRO(133.8,SRSS,1,"
SET DA(1)=SRSS
SET X=DFN
DO FILE^DICN
IF +Y
SET SROFN=+Y
+4 KILL DA,DIE,DR
SET DA=SRSS
SET DIE=133.8
SET DR="1///"_SRNM
SET DR(2,133.801)="1////"_SROPER_";2///"_SRSDT_";4T;W !;5T;6T;W !;3T"
SET DR(3,133.8013)=".01T;1T;2T;3T;4T;5T"
DO ^DIE
KILL DIE,DR
+5 DO WL^SROPCE1
IF SRSOUT
GOTO DEL
+6 WRITE @IOF,!,SRNM_" has been entered on the waiting list",!,"for "_SRSSNM
END DO PRESS
DO ^SRSKILL
WRITE @IOF
+1 QUIT
PRESS WRITE !
KILL DIR
SET DIR("A")="Press RETURN to continue "
SET DIR(0)="FOA"
DO ^DIR
KILL DIR
+1 QUIT
DEL SET DA(1)=SRSS
SET DA=SROFN
SET DIK="^SRO(133.8,"_DA(1)_",1,"
DO ^DIK
+1 WRITE @IOF,!,"Classification information is incomplete. No action taken."
GOTO END
+2 QUIT
HELP WRITE !!,"Enter RETURN if you want to continue entering a new procedure on the waiting",!,"list for "_SRNM_". If the procedure you are about to enter appears",!,"above, enter 'NO' to quit this option."
+1 WRITE !!,"Press RETURN to continue "
READ X:DTIME
+2 QUIT
CHK ; check for existing entries for a patient
+1 WRITE @IOF,!,"Procedure(s) already entered for "_SRNM,!,"on the Waiting List for "_SRSSNM,!
+2 SET SROFN=0
FOR
SET SROFN=$ORDER(^SRO(133.8,"AP",DFN,SRSS,SROFN))
if 'SROFN
QUIT
DO LIST
+3 WRITE !!,"Do you wish to continue entering a new procedure for "_SRNM_" on",!,"the waiting list for "_SRSSNM_" ? YES// "
READ ECYN:DTIME
IF '$TEST!(ECYN["^")
SET ECYN="N"
QUIT
+4 SET ECYN=$EXTRACT(ECYN)
if "y"[ECYN
SET ECYN="Y"
+5 IF "YNn"'[ECYN
DO HELP
GOTO CHK
+6 QUIT
LIST ; list existing procedures for specialty selected
+1 SET SROPER=$PIECE(^SRO(133.8,SRSS,1,SROFN,0),"^",2)
SET SRDT=$PIECE(^(0),"^",3)
SET SROPDT=$PIECE(^(0),"^",5)
SET Y=SRDT
DO D^DIQ
SET SRDT=$EXTRACT(Y,1,12)
IF SROPDT
SET Y=SROPDT
DO D^DIQ
SET SROPDT=$EXTRACT(Y,1,12)
+2 KILL SROP,MM,MMM
if $LENGTH(SROPER)<36
SET SROP(1)=SROPER
IF $LENGTH(SROPER)>35
SET SROPER=SROPER_" "
SET SROPER=SROPER_" "
FOR M=1:1
DO LOOP
if MMM=""
QUIT
+3 WRITE !,SRNM,?40,"Date Entered on List:",?66,SRDT,!,?3,SROP(1),?40,"Tentative Operation Date: ",?66,SROPDT
+4 IF $DATA(SROP(2))
WRITE !,?3,SROP(2)
+5 WRITE !
+6 QUIT
LOOP ; break procedure if greater than 36 characters
+1 SET SROP(M)=""
FOR LOOP=1:1
SET MM=$PIECE(SROPER," ")
SET MMM=$PIECE(SROPER," ",2,200)
if MMM=""
QUIT
if $LENGTH(SROP(M))+$LENGTH(MM)'<36
QUIT
SET SROP(M)=SROP(M)_MM_" "
SET SROPER=MMM
+2 QUIT
REFPHY ; Look up Referring Physician in "New Person" file with filter and auto-populate Referring Physician demographic fields
+1 NEW SRCONT,Y,SRDEMO
+2 SET SRCONT=""
PRMPT READ !,"Is this a VA Physician from this facility? (Y/N): <Y> ",SRCONT:DTIME
IF '$TEST
QUIT
+1 IF SRCONT["?"
Begin DoDot:1
+2 WRITE !!,"Enter 'Y' if you would like to select the Referring Physician from this facility's VA personnel.",!,"Enter 'N' to continue data entry.",!
End DoDot:1
GOTO PRMPT
+3 if SRCONT=""
SET SRCONT="Y"
+4 IF SRCONT="^"
SET X=""
QUIT
+5 if (SRCONT'["Y")&(SRCONT'["y")
QUIT
+6 ; Store FileMan variables and arrays
+7 MERGE SRDABAK=DA,SRDICBAK=DIC,SRDZERO=D0,SRDRBAK=DR,SRXBAK=X,SRDOBAK=DO
+8 ; Setup variables and call ^DIC to lookup REFERRING PHYSICIAN from NEW PERSON file
+9 SET DIC="^VA(200,"
SET DIC(0)="E"
SET DIC("B")=X
+10 ;SR*3*214 - KILL the default
DO ^DIC
KILL DIC("B")
+11 ; Restore FileMan's variables and arrays
+12 MERGE DA=SRDABAK,DIC=SRDICBAK,D0=SRDZERO,DR=SRDRBAK,X=SRXBAK,DO=SRDOBAK
+13 KILL SRCONT,SRDABAK,SRDICBAK,SRDZERO,SRDRBAK,SRXBAK,SRDOBAK
+14 ; Quit if no record was selected from the NEW PERSON file
if Y="-1"
QUIT
+15 ;The record number of the NEW PERSON file
SET SRNPREC=$PIECE(Y,U,1)_","
+16 ; Retrieve demographic data from the NEW PERSON file.
+17 DO GETS^DIQ(200,SRNPREC,".01:.116;.132","","SRDEMO")
+18 ; Build SRDEMO array for "stuffing" into REFERRING PHYSICIAN demographic fields
+19 ;Name
SET X=SRDEMO(200,SRNPREC,".01")
+20 ;Address
SET SRDEMO(1)=SRDEMO(200,SRNPREC,".111")
+21 ;Concatenate Address 2 to single address
if $LENGTH(SRDEMO(200,SRNPREC,".112"))>0
SET SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".112")
+22 ;Concatenate Address 3 to single address
if $LENGTH(SRDEMO(200,SRNPREC,".113"))>0
SET SRDEMO(1)=SRDEMO(1)_" "_SRDEMO(200,SRNPREC,".113")
+23 SET SRDEMO(1)=$EXTRACT(SRDEMO(1),1,75)
+24 ;City
SET SRDEMO(2)=SRDEMO(200,SRNPREC,".114")
+25 ;State
SET SRDEMO(3)=SRDEMO(200,SRNPREC,".115")
+26 ;Zip
SET SRDEMO(4)=SRDEMO(200,SRNPREC,".116")
+27 ;Office Phone
SET SRDEMO(5)=SRDEMO(200,SRNPREC,".132")
+28 ; Set up DR array that FileMan will use, with a call to ^DIE, after this subroutine Quits to "stuff" the demographic data.
+29 ; all fields except STATE will ignore input transform (SR*3.0*162)
+30 SET DIC("DR")="1////"_SRDEMO(1)_";2////"_SRDEMO(2)_";3///"_SRDEMO(3)_";4////"_SRDEMO(4)_";5////"_SRDEMO(5)_";6////"_$PIECE(Y,U,1)
+31 ;Tells FileMan to file the data without any more user input
SET DIC(0)="Z"
+32 QUIT
