- DGSWITCH ;SF/GFT/MIR - SWITCH BEDS ; 5/17/88 10:54 AM ;
- ;;5.3;Registration;**128**;Aug 13, 1993
- ;
- EN K ^UTILITY("DGPM",$J) S (DGSWITCH,DGOERR)=0,XQORQUIT=1 K ORACTION
- R !!,"SWITCH BED FOR PATIENT: ",X:DTIME G Q:X["^"!'$T!(X="") S DIC(0)="QZEM",DIC("S")="I $D(^(.1))" S DIC="^DPT(" D ^DIC G EN:Y'>0 S DFN=+Y
- OERR D INP^DGRPD I 'DGPMVI(1) W *7,!?5,"NO ADMISSIONS ON FILE!" G REASK
- W ! I DGPMDCD W !,"Patient is not in-house!",*7 G REASK
- S DIE="^DGPM(",DR=.07,DA=DGPMVI(13),I=DGPMVI(13,1)+.0000005 I $O(^DGPM("APCA",DFN,+DGPMVI(13),I))'>0 S DGPMT=1 D DIE G REASK
- S I=$O(^DGPM("APMV",DFN,+DGPMVI(13),0)),I=$O(^(+I,0)) I I>0,$D(^DGPM(+I,0)) S X="^"_$P(^(0),"^",18)_"^" I "^2^3^13^25^26^43^44^45^"[X W !,"Not while ",$S("^2^3^25^26^"[X:"on absence",1:"ASIH") G REASK
- S DA=I,DGPMT=2 D DIE
- REASK G EN:'$D(ORACTION)
- Q D KVAR^VADPT K:'$D(ORACTION) XQORQUIT K DFN,DGPMDA,DGPMDCD,DGPMA,DGPMOC,DGPMOS,DGPMP,DGPMT,DGPMVI,DGOERR,DGSWITCH,DIC,A,D,DA,DR,I,X,Y,DIE,^UTILITY("DGPM",$J) Q
- OREN S DGPMDA="",DGSWITCH=0 Q:'$D(ORVP) S (Y,DFN)=+ORVP G OERR
- DIE I $D(^DGPM(+DA,0)) S DGPMDA=DA,(DGPMP,^UTILITY("DGPM",$J,DGPMT,DA,"P"))=^(0) D ^DIE S (DGPMA,^UTILITY("DGPM",$J,DGPMT,DA,"A"))=^DGPM(DA,0) D RESET^DGPMDDCN
- I $D(DGPMP),(DGPMP'=DGPMA) D EN^DGPMVBM,^DGPMEVT
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSWITCH 1270 printed Feb 19, 2025@00:25:04 Page 2
- DGSWITCH ;SF/GFT/MIR - SWITCH BEDS ; 5/17/88 10:54 AM ;
- +1 ;;5.3;Registration;**128**;Aug 13, 1993
- +2 ;
- EN KILL ^UTILITY("DGPM",$JOB)
- SET (DGSWITCH,DGOERR)=0
- SET XQORQUIT=1
- KILL ORACTION
- +1 READ !!,"SWITCH BED FOR PATIENT: ",X:DTIME
- if X["^"!'$TEST!(X="")
- GOTO Q
- SET DIC(0)="QZEM"
- SET DIC("S")="I $D(^(.1))"
- SET DIC="^DPT("
- DO ^DIC
- if Y'>0
- GOTO EN
- SET DFN=+Y
- OERR DO INP^DGRPD
- IF 'DGPMVI(1)
- WRITE *7,!?5,"NO ADMISSIONS ON FILE!"
- GOTO REASK
- +1 WRITE !
- IF DGPMDCD
- WRITE !,"Patient is not in-house!",*7
- GOTO REASK
- +2 SET DIE="^DGPM("
- SET DR=.07
- SET DA=DGPMVI(13)
- SET I=DGPMVI(13,1)+.0000005
- IF $ORDER(^DGPM("APCA",DFN,+DGPMVI(13),I))'>0
- SET DGPMT=1
- DO DIE
- GOTO REASK
- +3 SET I=$ORDER(^DGPM("APMV",DFN,+DGPMVI(13),0))
- SET I=$ORDER(^(+I,0))
- IF I>0
- IF $DATA(^DGPM(+I,0))
- SET X="^"_$PIECE(^(0),"^",18)_"^"
- IF "^2^3^13^25^26^43^44^45^"[X
- WRITE !,"Not while ",$SELECT("^2^3^25^26^"[X:"on absence",1:"ASIH")
- GOTO REASK
- +4 SET DA=I
- SET DGPMT=2
- DO DIE
- REASK if '$DATA(ORACTION)
- GOTO EN
- Q DO KVAR^VADPT
- if '$DATA(ORACTION)
- KILL XQORQUIT
- KILL DFN,DGPMDA,DGPMDCD,DGPMA,DGPMOC,DGPMOS,DGPMP,DGPMT,DGPMVI,DGOERR,DGSWITCH,DIC,A,D,DA,DR,I,X,Y,DIE,^UTILITY("DGPM",$JOB)
- QUIT
- OREN SET DGPMDA=""
- SET DGSWITCH=0
- if '$DATA(ORVP)
- QUIT
- SET (Y,DFN)=+ORVP
- GOTO OERR
- DIE IF $DATA(^DGPM(+DA,0))
- SET DGPMDA=DA
- SET (DGPMP,^UTILITY("DGPM",$JOB,DGPMT,DA,"P"))=^(0)
- DO ^DIE
- SET (DGPMA,^UTILITY("DGPM",$JOB,DGPMT,DA,"A"))=^DGPM(DA,0)
- DO RESET^DGPMDDCN
- +1 IF $DATA(DGPMP)
- IF (DGPMP'=DGPMA)
- DO EN^DGPMVBM
- DO ^DGPMEVT
- +2 QUIT