- QAMC15 ;HISC/DAD-CONDITION: WARD TRANSFER ;7/27/92 13:04
- ;;1.0;Clinical Monitoring System;;09/13/1993
- EN1 ; *** CONDITION CODE
- S WARDGRP=$S($D(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
- F WARDDT=(QAMTODAY-.0000001):0 S WARDDT=$O(^DGPM("AMV2",WARDDT)) Q:(WARDDT'>0)!(WARDDT\1'?7N)!(WARDDT>(QAMTODAY+.9999999)) F QAMDFN=0:0 S QAMDFN=$O(^DGPM("AMV2",WARDDT,QAMDFN)) Q:QAMDFN'>0 D LOOP0
- K WARDGRP,WARDDT,WARDD0,WARD,QAMDGPM
- Q
- LOOP0 F WARDD0=0:0 S WARDD0=$O(^DGPM("AMV2",WARDDT,QAMDFN,WARDD0)) Q:WARDD0'>0 D LOOP1
- Q
- LOOP1 S QAMDGPM=$G(^DGPM(WARDD0,0)) Q:$P(QAMDGPM,"^",18)'=4 ; INTERWARD XFR
- I WARDGRP S WARD=+$P(QAMDGPM,"^",6) Q:$O(^QA(743.5,WARDGRP,"GRP","AB",WARD,0))'>0
- S ^UTILITY($J,"QAM CONDITION",QAMD1,QAMDFN)="",^(QAMDFN,WARDDT)=WARDD0
- Q
- EN2 ; *** PARAMETER CODE
- K DIC,DIR,DIRUT S DIC=743.5,DIC(0)="EMNQZ",DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=42"
- S DIC("A")="WARD GROUP: ",DIC("B")=$S($D(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:$P(^("P1"),"^",2),1:"") K:DIC("B")="" DIC("B")
- S DIR("?",1)="Enter a GROUP name that contains MAS ward locations,",DIR("?")="or press 'RETURN' for all ward locations."
- S QAMPARAM="P1" D EN2^QAMUTL1 I $D(DIRUT) S Y=-1 G Y
- S:Y]"" ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
- EXIT K Y
- K QAMPARAM,QAMY
- Y Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HQAMC15 1285 printed Jan 18, 2025@02:43:12 Page 2
- QAMC15 ;HISC/DAD-CONDITION: WARD TRANSFER ;7/27/92 13:04
- +1 ;;1.0;Clinical Monitoring System;;09/13/1993
- EN1 ; *** CONDITION CODE
- +1 SET WARDGRP=$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:+^("P1"),1:0)
- +2 FOR WARDDT=(QAMTODAY-.0000001):0
- SET WARDDT=$ORDER(^DGPM("AMV2",WARDDT))
- if (WARDDT'>0)!(WARDDT\1'?7N)!(WARDDT>(QAMTODAY+.9999999))
- QUIT
- FOR QAMDFN=0:0
- SET QAMDFN=$ORDER(^DGPM("AMV2",WARDDT,QAMDFN))
- if QAMDFN'>0
- QUIT
- DO LOOP0
- +3 KILL WARDGRP,WARDDT,WARDD0,WARD,QAMDGPM
- +4 QUIT
- LOOP0 FOR WARDD0=0:0
- SET WARDD0=$ORDER(^DGPM("AMV2",WARDDT,QAMDFN,WARDD0))
- if WARDD0'>0
- QUIT
- DO LOOP1
- +1 QUIT
- LOOP1 ; INTERWARD XFR
- SET QAMDGPM=$GET(^DGPM(WARDD0,0))
- if $PIECE(QAMDGPM,"^",18)'=4
- QUIT
- +1 IF WARDGRP
- SET WARD=+$PIECE(QAMDGPM,"^",6)
- if $ORDER(^QA(743.5,WARDGRP,"GRP","AB",WARD,0))'>0
- QUIT
- +2 SET ^UTILITY($JOB,"QAM CONDITION",QAMD1,QAMDFN)=""
- SET ^(QAMDFN,WARDDT)=WARDD0
- +3 QUIT
- EN2 ; *** PARAMETER CODE
- +1 KILL DIC,DIR,DIRUT
- SET DIC=743.5
- SET DIC(0)="EMNQZ"
- SET DIC("S")="I $P(^QA(743.5,+Y,0),""^"",2)=42"
- +2 SET DIC("A")="WARD GROUP: "
- SET DIC("B")=$SELECT($DATA(^QA(743,QAMD0,"COND",QAMD1,"P1"))#2:$PIECE(^("P1"),"^",2),1:"")
- if DIC("B")=""
- KILL DIC("B")
- +3 SET DIR("?",1)="Enter a GROUP name that contains MAS ward locations,"
- SET DIR("?")="or press 'RETURN' for all ward locations."
- +4 SET QAMPARAM="P1"
- DO EN2^QAMUTL1
- IF $DATA(DIRUT)
- SET Y=-1
- GOTO Y
- +5 if Y]""
- SET ^QA(743,QAMD0,"COND",QAMD1,"P1")=+Y_"^"_Y(0,0)
- EXIT KILL Y
- +1 KILL QAMPARAM,QAMY
- Y QUIT