- 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 Feb 19, 2025@00:13:10 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